
(* APPENDIX *) 



(* IMPLEMENTATION for IBM PERSONAL COMPUTER of 
Prof. N. WIRTH'S PASCAL-S modified from: 

1. "Pascal-S: A Subset and its Implementation", N. Wirth, 
from "PASCAL The Language and its Implementation", edited by D.W. 
Barron, John Wiley & Sons, 1981, Pp. 199-259; and 

2. "Programming Language Translation", R.E. Berry, Ellis 
Horwood Limited, 1982. 



The following source code is in Turbo Pascal by Borland 
International of Scotts Valley, California. *) 



{ The following included files are listed below this main file: } 



{$1 e:decl3 } 
{$1 e:edit4 } 
{$1 e:err3 } 
{$1 e:lex4 } 
{$1 e:entr } 
{$1 e:block3 } 
{$1 e:intr } 

PROCEDURE compinit ; 

BEGIN 

key[l] := 
key[2] := 
key[3] := 
key[4] := 
key[5] := 
key[6] := 
key[7] := 
key[8] := 
key[9] := 
key[10] : 
key[ll] : 
key[12] : 
key[13] : 
key[14] : 
key[15] : 
key[16] : 

1 



' and 
'array 

* begin 
'case 
'const 
' di v 

' do 

' downt o 

* else 
= * end 
= 'for 

= ' function 
= * if 
= ' mod 
= 'not 
= 'of 



key- 


17] 




= 'or 


key 


18] 




= 'procedure 


key 


19] 




= 'program 


key 


20 ] 




= 'record 


key 


21 ] 




= 'repeat 


key 


22 ] 




= ' then 


key 


23 ] 




= ' to 


key 


24] 




= 'type 


key 


25] 




= 'until 


key 


26] 




= ' var 


key 


27] 




= 'while 


ksy 


1 ] 


= andsy ; 


ksy 


2] 




= arraysy ; 


ksy 


3] 


= beginsy ; 


ksy 


4] 


= casesy ; 


ksy 


5] 




= constsy ; 


ksy 


6] 




= i d i v ; 


ksy 


7] 




= dosy ; 


ksy 


8] 




= downtosy ; 


ksy 


9] 




= elsesy ; 


ksy 


10 ] 




= endsy ; 


ksy 


11 ] 




= forsy ; 


ksy 


12 ] 




= functionsy 


ksy 


13] 




= ifsy ; 


ksy 


14] 




= imod ; 


ksy 


15] 




= notsy ; 


ksy 


16] 




= of sy ; 


ksy 


17] 




= orsy ; 


ksy 


18] 




= proceduresy 




1 Q 1 




= programsy ; 


ksy 


20] 




= recordsy ; 


ksy 


21] 




= repeatsy ; 


ksy 


22] 




= thensy ; 


ksy 


23] 




= tosy ; 


ksy 


24] 




= typesy ; 


ksy 


25] 




= untilsy ; 


ksy 


26] 




= varsy ; 


ksy 


27] 




= whilesy ; 



plus ; 
minus ; 
times ; 
r di v ; 
lparent ; 
rparent ; 
egl ; 
comma ; 
lbrack ; 
rbrack ; 
neg ; 
andsy ; 
semicolon ; 

:= [plus, minus, intcon,realcon,charcon, ident] 
:= [ ident , array sy , recordsy ] ; 

[ constsy , typesy , varsy , proceduresy , 
functionsy , beginsy ] ; 
facbegsys := [ intcon , realcon , charcon , ident , lparent , notsy ] 
statbegsys := [ beginsy , if sy , whilesy , repeatsy , for sy , casesy 
stantyps := [ notyp , ints , reals , bools , char s ] ; 
lc := 0 ; 
11 := 0 ; 



sps L 
sps [ 
sps [ 
sps [ 
sps [ 
sps [ 
sps [ 
sps [ 
sps [ 
constbegsy s 
typebegsys 
blockbegsy s 
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cc := 0 ; 
ch := ' » ; 
errpos := 0 ; 
errs : = [ ] ; 
compline := 1 ; 
t := - 1 ; 
a := 0 ; 
b := 1 ; 
sx := 0 ; 
c2 := 0 ; 
display[0] := 1 ; 
iflag := false ; 
oflag := false ; 
enter ( ' 
enter ( ' false 
enter ( ' true 
enter ( ' r eal 
enter ( ' char 
enter( 'boolean 
enter ( ' integer 
enter ( ' abs 
enter ( ' sqr 
enter ( ' odd 
enter ( * chr 
enter ( ' or d 
enter ( ' succ 
enter ( ' pred 
enter ( ' round 
enter ( ' tr unc 
enter ( 'sin 
enter ( 'cos 
enter ( ' exp 
enter ( ' In 
enter ( ' sqr t 
enter( 'arctan 
enter ( ' eof 
enter ( ' eoln 
enter ( ' read 
enter( 'readln 
enter ( * write 
enter( 'writeln 
enter ( * 

WITH btab[l] DO 
BEGIN 

last := t ; 
lastpar := 1 
psize := 0 ; 
vsize : = 0 
END ; 
errormsg ; 
END ; 



^variable ,notyp,0) 
,konstant, bools, 0) 
,konstant , bools, 1) 
, type 1 , reals , 1 ) ; 
, ty pel , char s , 1 ) ; 
, type 1 , bools , 1 ) ; 
,typel ,ints,l) ; 
, funktion , reals , 0) 
,funktion,reals,2) 
,funktion, bools, 4) 
,funktion,chars,5) 
, funktion , ints , 6 ) ; 
,funktion, chars, 7) 
, funktion , char s , 8 ) 
, funktion , ints , 9 ) ; 
,funktion,ints,10) 
(funktion, reals, 11) 
( funktion, reals , 12) 
(funktion, reals , 13) 
(funktion, reals, 14) 
.funktion, reals, 15) 
, f unkt ion , reals, 16) 
(funktion, bools, 17) 
, funktion , bools, 18) 
(prozedure,notyp, 1) 
( prozedure , notyp , 2) 
,prozedure,notyp,3) 
,prozedure,notyp,4) 
.prozedure, notyp, 0) 



( *sentinel* ) 



(* compinit *) 



PROCEDURE reinit 



BEGIN 
lc : 
11 : 
cc : 
ch : 
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errpos := 0 ; 
errs : = [ ] ; 
compline := 0 ; 
recompile := false ; 
errorstate := false 
linebuf : = * ' ; 
END ; 



BEGIN 

filesrch ; 
edinit ; 

pauseline := 0 ; 
IF newfile THEN 

FOR j := 1 TO linelimit 
bufarray[j] := NIL ; 



*) 



main *) 



gotoxy( 1, 
gotoxy ( 20 , 
go toxy ( 40 , 
gotoxy ( 60 , 
go toxy ( 70 , 



25) 
25) 
25) 
25) 
25) 



write( 'LINENUM = ' ) ; 
write( 'COMPLINE = '); 
write( 'PAUSELINE = '); 
write( 'CH = ' ) ; 
write( ' CC = * ) ; 



gotoxy(col.row) ; 
recomp : 

db( 'START RECOMP: * ) ; 
compinit ; 

db( 'AFTER COMPINIT ' ) ; 
reinit ; 

db( 'AFTER REINIT' ) ; 
(* status; *) 
insymbol ; 

IF sy <> programsy THEN 

error(3) 
ELSE 
BEGIN 

insymbol ; 
IF sy <> ident THEN 

error ( 2) 
ELSE 
BEGIN 

progname : 
insymbol ; 
END 
END ; 
block(blockbegsys 
IF recompile THEN 
BEGIN 

recompile := false ; 
GOTO recomp ; 
END ; 

IF sy <> period THEN 

error(22) ; 
emit(31) ; 

IF btab[2] . vsize > stacksize THEN 

error(49) ; 
IF progname = 'testO ' THEN 

printtables ; 
IF errs = [ ] THEN 

interpret 



id 



statbegsys, false, 1) 



(*halt*) 



ELSE 

err ormsg 
readln ; 
END. 



(* 



*) 



DECL3 .PAS 



LABEL 
r ecomp 

CONST 
nkw 
alng 
ling 
emax 
emin 
kmax 
tmax 
bmax 
amax 



27 ; 
10 ; 
120 ; 
322 ; 
-292 
15 ; 
100 ; 
20 ; 
30 ; 
c2max = 20 ; 
csmax = 30 ; 
cmax = 850 ; 
lmax = 7 ; 
smax = 600 ; 
ermax = 58 ; 
omax = 63 ; 
xmax = 32000 
nraax = 32000 
lineleng = 136; 
linelimit = 3000 
stacksize = 1500 



(*no. of key words*) 

(*no. of significant chars in identifiers*) 
(*input line length*) 
(*max exponent of real numbers*) 
(*min exponent*) 

(*max no. of significant digits*) 
(*size of table*) 
(*size of block-table*) 
(*size of array— table* ) 
(*size of real constant table*) 
(*max no. of cases*) 
(*size of code*) 
(♦maximum level*) 
(*size of string-table*) 
(*max error no.*) 
(♦highest order code*) 
(*2**17 - 1*) 
(*2**48-l*) 

(♦output line length*) 



TYPE 

symbol = 

(intcon.realcon, char con ,mstring,notsy, plus, minus, times, idiv.rdiv, 
imod ,andsy,orsy,egl,neg,gtr,geg,lss,leg,lparent,rparent,lbrack, 
rbrack, comma .semicolon, period, colon, becomes, constsy,typesy,varsy, 
functionsy,proceduresy,arraysy,recordsy, programsy , ident , beginsy , 
ifsy,casesy,repeatsy,whilesy,forsy,endsy,elsesy,untilsy,ofsy,dosy, 
tosy , downtosy , thensy ) ; 

index = — xmax.. + xmax ; 

alfa = STRING [ alng ] ; 

object = (konstant, variable, typel ,prozedure,funktion) ; 
types = ( notyp , ints , reals , bools , char s , arrays , records ) ; 
symset = SET OF symbol ; 
typset = SET OF types ; 
item = RECORD 

typ : types ; 

ref : index ; 
END ; 

order = PACKED RECORD 

f : - omax. . + omax ; 
x : - lmax. . + lmax ; 
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integer 



recpt r = 
liner ec 



y : - nmax. . + nmax ; 
END ; 

RECORD 

ax,bx,cx,dx,bp,si,di,ds,es,flags 
END ; 

"linerec ; 
= RECORD 

code : STRING[16] ; 
next : recptr ; 
END ; 

loctype = STRING[32] ; 
VAR 

sy : symbol; (*last symbol read by insymbol*) 
id : alfa ; (*identif ier from insymbol*) 
inum : integer ; (*integer from insymbol*) 
rnum : real ; (*real number from insymbol*) 

sleng : integer ;(*string length*) 

ch : char ; (*last character read from source program*) 

lline : ARRAY [L.llng] OF char ; 

cc : integer ; (*character counter*) 

lc : integer ; (*program location counter*) 

11 : integer ; (*length of current line*) 

errs : SET OF 0..ermax ; 

errpos : integer ; 

progname : alfa ; 

iflag,oflag : boolean ; 

constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset; 
key : ARRAY [l..nkw] OF alfa ; 
ksy : ARRAY [l..nkw] OF symbol ; 

sps : ARRAY [char] OF symbol ; (*special symbols*) 

t,a,b,sx,cl,c2 : integer ; (*indices to tables*) 

stantyps : typset ; 

display : ARRAY [0..1max] OF integer ; 



tab 



ARRAY [0..tmax] OF 



RECORD 




name : 


alfa ; 


link : 


index ; 


obj : 


object ; 


typ : 


types ; 


ref : 


index ; 


normal 


: boolean 


lev : 


0 . . lmax ; 


adr : 


integer ; 



(^identifier table*) 



END ; 

atab : ARRAY [l..amax] OF 
PACKED RECORD 

inxtyp,eltyp : types ; 

elref , low , high , elsize , size : inde 
END ; 

btab : ARRAY [L.bmax] OF 
PACKED RECORD 

las t , las t par , psize , vsize : index 
END ; 

stab : PACKED ARRAY [0..smax] OF char ; 
rconst : ARRAY [l..c2max] OF real ; 
code : ARRAY [0..cmax] OF order ; 
psin , psout , pr r , pr d : text ; 
inf.outf : STRING [24] ; 
i,j : integer ; 

bufarray : ARRAY [ 1 . . linelimi t ] OF recptr 



(*array-table*) 



(*block-table*) 



(♦string table*) 
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(* buffer array of line ptrs 
linenum ,topline,lastline, compline, pauseline, 
linebuf : STRING [80] ; 
regs : regrec ; 
row, col : integer ; 
buffed : boolean ; 
inserton : boolean ; 
recompile : boolean ; 
initialized : boolean ; 
c : char ; 

msg : ARRAY [0..ermax] OF alfa ; 
errorstate : boolean ; 
newfile : boolean ; 
PROCEDURE debug ; 

BEGIN 

i := i + 1 ; 
go toxy ( 0 , i ) ; 
writeln ; 

wri te ( ' cc = ' , cc ) 
write( 1 11 = » ,11) 
write( ' ch = ' ,ch) 
writeln ; 
END ; 



integer 



PROCEDURE displaysy ; 

BEGIN 

CASE sy OF 

semicolon : BEGIN 

writeln( 1st , ' semicolon 
END ; 
ident : BEGIN 

writeln( 1st , ' ident ') 
END ; 
rparent : BEGIN 

wr i teln( 1st , ' rparent 
END ; 
varsy : BEGIN 

wr i teln( 1st , ' varsy 
END ; 
forsy : BEGIN 

wri t eln( 1st , ' forsy 
END ; 
dosy : BEGIN 

wr i teln ( 1 s t , * dosy 
END ; 
becomes : BEGIN 

wr i teln( 1st , ' becomes 
END ; 
tosy : BEGIN 

wr i t eln( 1st , ' tosy ') ; 
END ; 
intcon : BEGIN 

writeln( 1st , ' intcon 
END ; 
whilesy : BEGIN 

wr iteln( 1st , ' whilesy f ) 
END ; 

beginsy : BEGIN 



(* readln; *) 



') 
') 



c 
*) i 
(< 
c 
(* 
') i 
(* 



readln ; 



readln ; 



(* 

readln; * ) 
readln; *) 

readln; *) 
(* readln; 

readln; *) 
(* 

( 



*) 



readln ; 



*) 



readln ; 



writeln( 1st , ' beginsy 
END ; 

ELSE 
BEGIN 

wri teln( 1st , ' unknown ') ; 
END ; 
END ; 
END ; 



*) ; O 



r eadln ; 



PROCEDURE tr(i:integer) ; 

(* trace - writes line number of source code at execution 



BEGIN 

(* gotoxy ( 1 , 16 + i) ; 
writeln( 'TRACE LINE *, 
gotoxy(col, row); *) 
END ; 



i); 



PROCEDURE status ; 

(* write status line values of 

linenum, compline, pauseline, cc, 



ch *) 



BEGIN 

gotoxy( 11 , 25) 
write (linenum) 
gotoxy(31 , 25) 
wr ite ( compline) 
gotoxy (52 , 25) 
write (pauseline) 
gotoxy (65 , 25) 
wr i te ( ch ) ; 
gotoxy(75,25) 
wr i te ( cc ) ; 

END ; 



PROCEDURE db( loc : loctype) 



BEGIN 



(* 



writeln(lst) ; 
wr iteln( 1st , 
writeln( 1st , 
wr i teln( 1st , 



' , linenum , ' ' , 
lastline, * 
compline ) ; 
pauseline , 



loc) ; 
' linenum 
' lastline 
'compline = 
writeln(lst, 'pauseline = 

' ch = ' , ch) ; 
writeln(lst, linebuf); 

writeln(lst, 'row = ', row, ' ', 'col = 
if buffed then writeln(lst, 'BUFFED') 

else writeln(lst, 'NOT buffed'); 
if inserton then writeln(lst, 'INSERTON') 

else writeln(lst, 'NOT inserton'); 
if recompile then writeln(lst, 'RECOMPILE') 

else writeln(lst, 
if initialized then writeln(lst 



' topline 



col) ; 



topline ) ; 



'NOT recompile'); 
" INITIALIZED* ) 



else writeln(lst, 'NOT initialized'); 



if errorstate then writeln(lst, 
else writeln(lst, 

display sy ; 



'ERRORSTATE' ) 
'NOT errorstate'); 



") 
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EDIT4.PAS 



*) 



PROCEDURE clearscreen(rowh , rowl : integer) 



BEGIN 

regs.ax := 6 * 256 
regs.cx : = (rowh - 
regs.dx := (rowl - 
regs.bx := 7 * 256 
intr ( $10 , regs ) ; 

END ; 



; (* ah = 6; al = 0 *) 

1) * 256 ; (* first row cleared *) 

1) * 256 + 80 ; (* last row cleared *) 

; (* bh = 7 for black/white attribute 



*) 



PROCEDURE outch(ch:char) ; 

(* output char to screen *) 

BEGIN 

regs.ax := $0A00 + ord(ch) ; 
regs.bx : = 1 ; 
regs.cx := 1 ; 
intr( $10 , regs) ; 
END : 



AH = 10; AL = char *) 



FUNCTION keyhit : boolean ; 

(* poll whether key struck *) 

BEGIN 

regs.ax := 11 * 256 ; 

intr ( $21 , regs) ; 

IF regs.ax > 11 * 256 THEN 

keyhit := true 
ELSE 

keyhit := false ; 
END ; 



(* 



*) 



FUNCTION inkey : char ; 

(* returns char if key struck; 



otherwise null 



BEGIN 

regs.ax := $600 ; 
regs.dx := $FF ; 
intr($21 ,regs) ; 

inkey := chr(regs.ax - $600) ; 
END ; 

(* editor buffer scheme — array of pointers to linked 
lists of line segments — each segment a record 
linked to the next segment of the same line - 
each record comprises a 16-bit character string 
and a pointer to the next record of same line *) 




FUNCTION buftolist : recptr ; 

(* converts 80-byte string (linebuf) to 
linked list of 16-byte records *) 

VAR 

lptr , rptr , oldptr : recptr ; 
i t numrecs , tail : integer ; 

BEGIN (* buftolist *) 

db ( ' START BUFTOLIST*) ; 
new(rptr) ; 
rptr* .code := ff ; 
rptr*. next : = NIL ; 
lptr := rptr ; 

numrecs := leng t h ( 1 ine buf ) DIV 16 ; 
tail := length(linebuf) MOD 16 ; 
FOR i := 1 TO numrecs DO 
BEGIN 

rptr*. code := copy ( linebuf ,( i - 1) * 16 + 1,16) ; 

oldptr := rptr ; 

new(rptr) ; 

rptr*. code := ; 

rptr*. next := NIL ; 

oldptr*. next := rptr ; 
END ; 
IF tail > 0 THEN 
BEGIN 

oldptr := rptr ; 

new(rptr) ; 

rptr*. code := ' ' ; 

rptr*. next : = NIL ; 

oldptr*. next := rptr ; 

rptr*. code := copy ( linebuf , numrecs * 16 + l,tail) ; 
END ; 

rptr*. next := NIL ; 
buftolist := lptr ; 
END ; 

(* buftolist *) 

PROCEDURE listobuf ( lptr : recptr ) ; 

(* converts linked list of 16-byte records 
to 80-byte line string (linebuf) *) 

VAR 

rptr : recptr ; 

BEGIN (* listobuf *) 

rptr := lptr ; 
linebuf := ; 
WHILE rptr <> NIL DO 
BEGIN 

linebuf := concat ( linebuf , rptr *. code) ; 
rptr := rptr*. next ; 
END ; 

db( 'END LISTOBUF' ) ; 
END ; 

(* listobuf *) 

PROCEDURE writebuf ; 
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VAR 

i : integer ; 

BEGIN (* writebuf *) 

clearscreen( 1 , 24) ; 
gotoxy(l,l) ; 
FOR i := 1 TO lastline DO 
BEGIN 

listobuf ( buf array [ i ] ) ; 
writeln( linebuf ) ; 
END ; 

END ; (* writebuf *) 
PROCEDURE scrolldn(rowtop,rowbot:integer) ; 
BEGIN 

regs.ax := 7 * 256 +1 ; (* AH = 7; AL = 1 line blanked *) 
regs.cx := (rowtop - 1) * 256 ; 

(* CH = row, CL = 0 : upper left corner *) 
regs.dx := (rowbot - 1) * 256 + 79 ; 

(* DH = row, DL = 80 : lower right corner *) 
regs.bx := 7 * 256 ; ( * black/white attribute *) 
intr ($10,regs) ; 
END ; 

PROCEDURE scrollup(rowtop , rowbot : integer ) ; 
BEGIN 

regs.ax := 6 * 256 + 1 ; (* AH = 6; AL = 1 line blanked *) 
regs.cx := (rowtop - 1) * 256 ; 

(* CH = row, CL = 0 : upper left corner *) 
regs.dx := (rowbot - 1) * 256 + 79 ; 

(* DH = row, DL = 80 : lower right corner *) 
regs.bx := 7 * 256 ; (* black/white attribute *) 
intr($10,regs) ; 
END ; 

PROCEDURE creturn ; (* carriage return *) 
BEGIN 

db ( * START CRETURN 1 ) ; 

IF (buf array[linenum] <> NIL) AND ( NOT buffed) THEN 
listobuf ( buf array [ linenum ] ) ; 

(* convert linked list to linebuf *) 
linebuf := linebuf + chr(13) ; 
ch := ' " ; 

buf array [ linenum] := buftolist ; 

(* convert linebuf to linked list *) 
buffed := false ; 
IF lastline < linenum THEN 

lastline := linenum ; 
pauseline := linenum ; 
linenum := linenum + 1 ; 
gotoxy (53, 25) ; 
linebuf := ? ' ; 
IF row < 24 THEN 

row := row + 1 
ELSE 

BEGIN 

topline := topline + 1 ; 
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# # 



scrollup( 1 , 24) ; 
END ; 
col := 1 ; 
(* status; *) 
gotoxy (col , row) ; 
inserton := true ; 
db( * END CRETURN' ) ; 
END ; 

PROCEDURE cursup ; 

BEGIN 

IF linenum > 1 THEN 
BEGIN 

IF buffed THEN (* line is in linebuf 

BEGIN 

buffed := false ; 

buf array [ linenum ] := buftolist ; 
END ; 
IF row > 1 THEN 

row := row - 1 ; 
gotoxy ( col , row) ; 
linenum := linenum - 1 ; 
pauseline := linenum — 1 ; 
IF pauseline <= compline THEN 
recompile := true ; 
END ; 
END ; 

PROCEDURE cursdn ; 

BEGIN 

IF linenum < lastline THEN 
BEGIN 

IF buffed THEN (* line is in linebuf 

BEGIN 

buffed := false ; 

buf array [ linenum ] := buftolist ; 
END ; 
row := row + 1 ; 
gotoxy ( col , row) ; 
linenum := linenum + 1 ; 
pauseline := linenum — 1 ; 
IF pauseline <= compline THEN 
recompile := true ; 
END ; 
END ; 

PROCEDURE curslt ; 

BEGIN 

col := col - 1 ; 

got oxy ( col , r ow ) ; 
END ; 

PROCEDURE cursrt ; 

BEGIN 

col := col + 1 ; 
go toxy ( col , r ow ) ; 
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PROCEDURE pageup ; 
VAR 

stopline, j : integer ; 
BEGIN 

db( 'START PAGEUP') ; 
IF buffed THEN 
BEGIN 

buffed := false ; 

buf array [ linenum ] := buftolist 
END ; 

clear screen ( 1 , 25 ) ; 
gotoxy(l.l) ; 
topline := topline - 24 ; 
IF topline < 1 THEN 

topline := 1 ; 
IF topline > lastline - 23 THEN 

stopline := lastline 
ELSE 

stopline := topline + 23 ; 
FOR j := topline TO stopline DO 
BEGIN 

lis tobuf ( buf array [ j ] ) ; 
wr i teln ( linebuf ) ; 
END ; 

linenum := topline ; 

pauseline := linenum - 1 ; 

IF pauseline <= compline THEN 

recompile : = true ; 
row := 1 ; 
col := 1 ; 
gotoxy ( col , row) ; 
db( ' END PAGEUP » ) ; 
END ; 

PROCEDURE pagedn ; 

VAR 

stopline, j : integer ; 

BEGIN 

IF buffed THEN 
BEGIN 

buffed := false ; 

buf array [ linenum ] := buftolist 
END ; 

gotoxy(l.l) ; 
topline := topline + 24 ; 
IF topline > lastline - 23 THEN 
BEGIN 

topline := lastline - 23 ; 
stopline := lastline ; 
END 
ELSE 

stopline := topline + 23 ; 
IF topline < 1 THEN 
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topline := 1 ; 
FOR j := topline TO stopline DO 
BEGIN 

listobuf ( buf array [ j ] ) ; 
wr iteln ( linebuf ) ; 
END ; 

linenura := topline ; 

pauseline := linenum - 1 ; 

IF pauseline <= compline THEN 

recompile := true ; 
row := 1 ; 
col := 1 ; 
go t oxy ( col , r ow ) ; 
END ; 

PROCEDURE pagecomp ; 
VAR 

stopline, j : integer ; 

BEGIN 

IF buffed THEN 
BEGIN 

buffed := false ; 

buf array [ linenum ] := buftolist 
END ; 

clearscreen(l,24) ; 
gotoxy(l.l) ; 

topline := compline - 10 ; 
IF topline < 1 THEN 

topline := 1 ; 
FOR j := topline TO compline DO 

BEGIN 

listobuf ( buf array [ j ] ) ; 
wr iteln ( linebuf ) ; 
END ; 

linenum := compline ; 
row := compline - topline + 1 ; 
col : = cc ; 
END ; 

PROCEDURE insrtog ; 

(* toggle insert mode *) 

BEGIN 

IF inserton THEN 

inserton := false 
ELSE 

inserton := true ; 
END ; 

PROCEDURE delchar ; 

(* delete character *) 

BEGIN 

IF NOT buffed THEN 
BEGIN 

listobuf ( buf array [ linenum] ) ; 
buffed := true ; 
END ; 
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delete ( linebuf , col , 1 ) ; 
go toxy ( 1 , r ow ) ; 
writeln(linebuf) ; 

gotoxy ( length( linebuf ) + l,row) ; 
outchC f ) ; 
go toxy ( col , r ow) ; 
END ; 

PROCEDURE insline ; 
VAR 

j : integer ; 
rptr : recptr ; 

BEGIN 

FOR j := linelimit DOWNTO linenum + 1 DO 

bufarray[j] := bufarray[j - 1] ; 
lastline := lastline + 1 ; 
new( r pt r ) ; 

rptr*. code := chr(13) ; 
rptr*. next := NIL ; 
buf array [ 1 inenum ] := rptr ; 
scrolldn ( r ow , 24) ; 
col := 1 ; 
gotoxy ( col , row) ; 
END ; 

PROCEDURE deline ; 

(* delete line *) 

VAR 

j : integer ; 
BEGIN 

(* disposeline ( linenum) *) 

FOR j := linenum TO lastline - 1 DO 

bufarray[j] := buf array[ j + 1] ; 
buf array [ lastline ] ;= NIL ; 
lastline := lastline - 1 ; 
scrollup(row, 24) ; 
gotoxy(l,24) ; 

lis tobuf ( buf array [ topline + 23]) ; 
writeln( linebuf ) ; 
col := 1 ; 
gotoxy ( col , row) ; 
END ; 

PROCEDURE filesrch ; 

(* search directory for file name in command line parameter *) 
VAR 

i,j,al : integer ; (* AL register *) 

fvar : text ; 

lbuf : STRING [80] ; 

fname : STRING [16] ; 

BEGIN 

fname : = ' ' ; 

FOR i := 1 TO 8 DO 

IF chr(mem[cseg: $5c + i - 1]) > ' ' THEN 

15 




fname := fname + chr (mem[ cseg : $5c + i - 1]) ; 
fname := fname + ' . ' ; 
FOR i := 9 TO 12 DO 

IF chr(mem[cseg:$5c + i - 1]) > ' ' THEN 

fname := fname + chr ( mem [ cseg : $5c + i - 1]) ; 
assign( fvar , fname) ; 
al := 1 ; 

regs.ax := $11 * 256 ; 

regs.dx := $5c ; (* FCB (File Control Block) address *) 

regs.ds := cseg ; (* code segment register *) 

intr ($21 , regs) ; 

al := regs.ax - $11 * 256 ; 

IF al = 0 THEN (* file exists *) 

BEGIN 

newfile := false ; 
reset(fvar) ; 
3 := 1 ; 
lastline := 0 ; 
WHILE NOT eof(fvar) DO 
BEGIN 

r eadln ( f var , 1 inebuf ) ; 
bufarray[j] := buftolist ; 
j := j + 1 ; 

lastline := lastline + 1 ; 
END ; 
close(fvar) ; 
END 
ELSE 

(* new file *) 

BEGIN 

newfile := true ; 
lastline := 0 ; 
END ; 
END ; 

PROCEDURE edinit ; 

(* initialize editor *) 

VAR 

j : integer ; 

BEGIN 

clear screen ( 1 , 24 ) ; 
row := 1 ; 
col := 1 ; 
gotoxy ( col , row) ; 
buffed := false ; 
topline := 1 ; 
linenum := 1 ; 
pageup ; 

inserton := true ; 

c : = ' T ; 

IF newfile THEN 

bufarray[l] := NIL ; 
END ; 

PROCEDURE compile ; 
BEGIN 

db( 'START COMPILE' ) ; 
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pauseline := lastline + 1 ; 
IF buffed THEN 
BEGIN 

buffed := false ; 

buf array [ linenum ] := buftolist ; 
END ; 

db( 'END COMPILE ' ) ; 
END ; 

PROCEDURE edit ; 
( * var 

c : char ; * ) 

BEGIN 

c := inkey ; 
IF ord(c) >= 32 THEN 
BEGIN 

IF NOT buffed THEN 
BEGIN 

linenum := topline + row - 1 ; 
IF bufarray [linenum] <> NIL THEN 

listobuf (buf array [linenum] ) ; 
buffed := true ; 
END ; 

WHILE col > length(linebuf) + 1 DO 
linebuf := linebuf + ' ' ; 

IF inserton THEN 
BEGIN 

insert ( c , linebuf , col ) ; 
got oxy ( 1 , row) ; 
writeln( linebuf ) ; 
col : = col + 1 ; 
gotoxy ( col , row) ; 
END 

ELSE (* not in insert mode *) 
BEGIN 

linebuf [col] := c ; 

outch(c) ; 

col := col + 1 ; 

gotoxy ( col , row) ; 
END ; 

IF linenum <= compline THEN 

recompile := true ; 
pauseline := linenum — 1 ; 
(* if pauseline <= compline then 

recompile := true; 



END (* regular character *) 
ELSE (* control character *) 
CASE ord(c) OF 

11,5 : (* A E *) 

cursup ; 

10,24 : (* *X *) 

cursdn ; 

8,19 : (* A S *) 

curslt ; 

12,4 : (* *D *) 

cursrt ; 

18 : (* A R *) 

pageup ; 
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1 6 : 


( * 




) 


pagedn ; 
22 : 


( * 




* ) 


insrtog ; 
14 : 


( * 






insline ; 
7 : 


( * 


* G 


* ) 


delchar ; 
25 : 


(* 


A Y 


*) 


deline ; 
13 : 


(* 


CR 


*) 


creturn ; 
3 : 


(* 


A c 


*) 


compile ; 
ELSE 









END ; 
(* status; *) 
gotoxy(col,row) 
END ; 



ERR3.PAS *) 



PROCEDURE errormsg 



VAR 
k 



integer 



BEGIN 
msg[0] 
msg [ 1 ] 
msg[2] 
msg[3] 
msg [ 4 ] 
msg[5] 
msg [ 6 ] 
msg[ 7 ] 
msg[8] 
msg[9] 
msg[10] 
msg [ 1 1 ] 
msg [ 12] 
msg[ 13 ] 
msg[ 14] 
msg[ 15 ] 
msg [ 16 ] 
msg[ 17 ] 
msg[ 18] 
msg[ 19] 



undef id 
multi def 
identifier 
program 
) 

syntax 
ident, var 
of 



= '( 



func. type 

boolean 
convar typ 
type 



18 





msg[20] : 


= 


prog . par am 


msg[21] : 


= 


' too big 


msg[22] : 






msg[23] : 




T typ (case) 


msg[24] : 


= 


char ac t er 


msg[25] : 


= 


const id 


msg[26] : 


= 


index type 


msg[27] : 




* indexbound 


msg[28] : 


= 


'no array 


msg[29] : 


= 


' type i d 


msg[30] : 


= 


' undef type 


msg[31] : 


= 


' no record 


msg[32] : 


= 


' boole type 


msg[33] ' 


= 


* arith type 


msg [ 34 ] 


= 


' integ 


msg [ 35 ] 


= 


' types 


msg [ 36 ] 


= 


param type 


msg [ 37 ] 




var iab id 


msg [ 38 ] 


= 


ms t r ing 


msg [ 39 ] 


= 


no .of pars 


msg [ 40 ] 


= 


T type 


msg [ 41 ] 


= 


f type 


msg [ 42 ] 


= 


' real type 


msg [ 43 ] 


= 


integer 


msg [ 44 ] 




var , const 


msg [ 45 ] 




var , proc 


msg[ 46 ] 




* types ( : =) 


msg [ 47 ] 




*typ (case) 


msg [ 48 ] 




'type 


msg [ 49 ] 




store ovfl 






constant 


msg [ 51 ] 






msg[52] 




' the 


msg[53] 




' until 


msg [ 54 ] 




'do 


msg [ 55 ] 




' to downto 


msg[56] 




' begin 


msg[ 57 ] 




' end 


msg[58] 




'factor 



PROCEDURE makelline(lineno: integer ) ; 

(* convert linked list of 16-byte records to array lline *) 

VAR 

j : integer ; 
rptr : recptr ; 
compbuf : STRING [80] ; 



END 



( *er r ormsg* ) 




(* LEX4.PAS *) 



BEGIN 
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rptr : = buf array [ lineno ] ; 
compbuf : = ' ' ; 
WHILE rptr <> NIL DO 
BEGIN 

compbuf := concat( compbuf , rptr *. code) 
rptr := rptr*. next ; 
END ; 

11 := length( compbuf ) ; 
FOR j := 1 TO 11 DO 

lline[j] := compbuf [j] ; 
db ( ' END MAKELLINE ' ) ; 
END ; 

PROCEDURE nextch ; 

BEGIN 

IF keypressed THEN 

edit ; 
IF cc = 11 THEN 

BEGIN 

(* 

if ord(ch) = 26 then 
begin 

wr i teln ; 

writeln( ' program incomplete'); 
er r ormsg ; 
end ; 

*) 

11 := 0 
cc : = 0 

IF compline < pauseline THEN 
BEGIN 

db('COMPLINE < PAUSELlNE*) ; 
compline := compline + 1 ; 
gotoxy (32 , 25) ; 

(* write ( compline ) ; *) 

makelline ( compline ) ; 

(* convert linked list line to array lline *) 
END ; 

END ; (* cc = 11 *) 

IF 11 = 0 THEN 

ch := 1 ' 
ELSE 
BEGIN 

cc := cc + 1 ; 
ch : = lline [ cc ] ; 
(* gotoxy(65, 25); 

write( ch) ; 
gotoxy(75, 25); 
write(cc) ; *) 

gotoxy ( col , row) ; 
END ; 
END ; 



*) 



PROCEDURE error (n: integer ) 
BEGIN 

IF NOT errorstate THEN 
BEGIN 



errorstate := true ; 
pauseline := compline - 1 ; 
recompile : = true ; 
clear screen( 1 , 25 ) ; 
topline := compline + 1 ; 
IF topline < 1 THEN 

topline := 1 ; 
pageup ; 
gotoxy(l,20) ; 

writeln( ' LINE : compline, ' 
col := cc ; 

row := compline — topline + 
gotoxy ( col , row) ; 
linenum := compline ; 
END ; 
(* status; *) 
END 



'ERROR: ',msg[n]) 



(♦error*) 



PROCEDURE fatal(n : integer ) 



VAR 
msg 



ARRAY [ 1 . .7] OF alfa 



BEGIN 

writeln ; 

er r ormsg 

msg[ 1 ] 

msg[2] 

msg [ 3 ] 

msg [ 4 ] 

msg[ 5 ] 

msg[6] 

msg[ 7 ] 

writeln( ' 

{goto 99} 
END 



identifier ' 
procedures' 
reals 
arrays 
levels 
code 
strings 

compiler table for ',msg[n], 
(* terminate compilation*) 



' is too small ' ) 
(*f atal*) 



PROCEDURE insymbol ; (*reads next symbol*) 

LABEL 

1,2, 3, quit ; 

VAR 

i , j , k , e : integer ; 
PROCEDURE readscale ; 
VAR 

s,sign : integer ; 



BEGIN 

nextch ; 
sign := 1 ; 
s := 0 ; 

IF ch = '+' THEN 

nextch 
ELSE IF ch = '-' THEN 

BEGIN 



nextch ; 
sign : = - 1 
END ; 

WHILE ch IN [ , 0 , .. , 9 I ] DO 

BEGIN 

s := 10 * s + ord(ch) 
nextch 
END ; 
e : = s * sign + e 
END 



ord( '0' ) 



(*readscale*) 



PROCEDURE adjustscale 

VAR 
s 

d, 



integer 
: real ; 



BEGIN 

IF k + e > emax THEN 

error ( 21 ) 
ELSE IF k + e < emin THEN 

rnum := 0 
ELSE 
BEGIN 

s : = abs(e) ; 
t := 1.0 ; 
d := 10.0 ; 
REPEAT 

WHILE NOT odd(s) DO 
BEGIN 

s := s DIV 2 ; 
d : = sqr ( d ) 
END ; 
s : = s — 1 ; 
t := d * t 
UNTIL s = 0 ; 
IF e >= 0 THEN 

rnum := rnum * t 
ELSE 

rnum := rnum / t 

END 

END 

BEGIN 

IF recompile THEN 
GOTO quit ; 

WHILE ch <= ' ' DO 

nextch ; 
IF ch IN [ 'a* . . 'z' ] THEN 

BEGIN 

k := 0 ; 

id := ' ' ; 

REPEAT 

IF k < alng THEN 
BEGIN 

k := k + 1 ; 
id[k] := ch 
END ; 



(*adjustscale*) 
( *insymbol* ) 



( *wor d* ) 
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nex tch 

UNTIL NOT (ch IN [ ' a * . . 1 z ' , 1 0 ' . . T 9 » ] ) ; 
i := 1 ; 

j := nkw ; (*binary search*) 

REPEAT 

k := (i + j) DIV 2 ; 

IF id <= key[k] THEN 
j := k - 1 ; 

IF id >= key[k] THEN 
i := k + 1 
UNTIL i > j ) 
IF i - 1 > j THEN 

sy := ksy[k] 
ELSE 

sy := ident ; 

END 

ELSE IF ch IN [ , 0 , .. , 9 f ] THEN 

BEGIN (*number*) 
k := 0 ; 
inum := 0 ; 
sy := intcon ; 
REPEAT 

inum := inum * 1 0 + ord(ch) - ord('O') : 

k := k + 1 ; 

nextch 

UNTIL NOT (ch IN [ , 0 , .. , 9 f ]) ; 

IF (k > kmax) OR (inum > nmax) THEN 
BEGIN 

error(21) ; 
inum := 0 ; 
k := 0 
END ; 
IF ch = '.' THEN 
BEGIN 

nextch ; 

IF ch = » . ' THEN 
ch := ' : » 

ELSE 
BEGIN 

sy := realcon ; 
rnum := inum ; 
e := 0 ; 

WHILE ch IN [ f 0' . . f 9' ] DO 
BEGIN 

e := e - 1 ; 

rnum := 10.0 * rnum + (ord(ch) - ord('O')) 
nextch 
END ; 
IF ch = *e* THEN 

readscale ; 
IF e <> 0 THEN 
ad justscale 

END 

END 

ELSE IF ch = 'e' THEN 
BEGIN 

sy := realcon ; 
rnum := inum ; 
e := 0 ; 
readscale ; 
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IF e <> 0 THEN 
adjustscale 
END ; 

END 
ELSE 

CASE ch OF 
f : ' : BEGIN 

nextch ; 

IF ch = ' = ' THEN 
BEGIN 

sy := becomes ; 
nextch 
END 
ELSE 

sy := colon 
END ; 
'<' : BEGIN 

nextch ; 

IF ch = *=' THEN 
BEGIN 

sy := leg ; 

nextch 
END 

ELSE IF ch = *>' THEN 
BEGIN 

sy := neg ; 
nextch 
END 
ELSE 

sy : = lss 
END ; 
»>» : BEGIN 

nextch ; 

IF ch = ' = ' THEN 
BEGIN 

sy := geg ; 
nextch 
END 
ELSE 

sy := gtr 
END ; 
' .* : BEGIN 

nextch ; 

IF ch = f . ' THEN 
BEGIN 

sy := colon ; 
nextch 
END 
ELSE 

sy := period 
END ; 
• ' ' * : BEGIN 

k := 0 ; 

nextch ; 

IF ch = ' f ' f THEN 
BEGIN 

nextch ; 

IF ch <> * • * » THEN 
GOTO 3 
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# 



END ; 

IF sx + k = smax THEN 

fatal(7) ; 
stab[sx + k] := ch ; 
k := k + 1 ; 
IF cc = 1 THEN 

BEGIN (* nd of line*] 

k := 0 ; 

END 
ELSE 

GOTO 2 ; 

3: 

IF k = 1 THEN 
BEGIN 

sy := charcon ; 

inum := or d ( s tab [ sx ] ) 
END 

ELSE IF k = 0 THEN 
BEGIN 

error(38) ; 
sy := charcon ; 
inum := 0 
END 
ELSE 
BEGIN 

sy : = mstring ; 
inum := sx ; 
sleng := k ; 
sx := sx + k 
END 
END ; 
' ( * : BEGIN 

nextch ; 

IF ch <> »*» THEN 

sy : = lparent 
ELSE 

BEGIN (*comment*) 
nextch ; 
REPEAT 

WHILE ch <> DO 

nextch ; 
nextch 
UNTIL ch = ' ) ' ; 
nextch ; 
GOTO 1 
END 
END ; 

• + t t ._» f t*t^T / , ) t ) t j t = , f t f , ) t [ T > , ] t j , # t > t & , t ,.t 

BEGIN 

sy : = sps [ ch ] ; 

nextch 
END ; 

*$ 1 ,*%*, '@* \ *, '~\'{' ,')','* ' : BEGIN 

error(24) ; 
nextch ; 
GOTO 1 
END 

END ; 

quit : 

END (*insymbol*) 
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(* ENTR.PAS *) 



PROCEDURE enter (xO: alf a ; 

xlrobject ; 
x2:types ; 
x3 : integer ) 

BEGIN 

t := t + 1 ; (*enter 
WITH tab[t] DO 
BEGIN 

name := xO ; 

link := t - 1 ; 

o b j : = x 1 ; 

typ := x2 ; 

ref := 0 ; 

normal := true ; 

lev := 0 ; 

adr := x3 
END 

END 



standard identifier*) 



(*enter*) 



PROCEDURE enterarray( tp : types ; 

1 , h : integer ) 



BEGIN 

IF 1 > h THEN 
error(27) ; 
IF (abs(l) > xmax) OR (abs(h) > xmax) THEN 
BEGIN 

error(27) ; 



1 
h 

END 



= 0 
0 



IF a = amax THEN 

f atal(4) 
ELSE 
BEGIN 

a : = a + 1 ; 
WITH atab[a] DO 
BEGIN 

inxtyp := tp 
low := 1 ; 
high := h 
END 

END 

END 



(*enterarray*) 
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PROCEDURE enterblock ; 

BEGIN 

IF b = bmax THEN 

f atal(2) 
ELSE 
BEGIN 

b := b + 1 ; 
btab[b].last := 0 ; 
btab [ b ] . lastpar := 0 
END 

END (*enterblock*) 



PROCEDURE enterreal(x: real) ; 
BEGIN 

IF c2 = c2max - 1 THEN 

fatal(3) 
ELSE 

BEGIN 

rconst[c2 + 1] := x ; 
cl := 1 ; 

WHILE rconst[c2 + 1] <> x DO 

cl := cl + 1 ; 
IF cl > c2 THEN 

c2 := cl 

END 

END (*enterreal*) 



PROCEDURE emit(fct : integer) ; 

BEGIN 

IF lc = cmax THEN 

fatal(6) ; 
code[lc].f := fct ; 
lc := lc + 1 

END (*emit*) 



PROCEDURE emitl ( fct , b : integer ) ; 

BEGIN 

IF lc = cmax THEN 

fatal(6) ; 
WITH code[lc] DO 
BEGIN 

code[ lc ] . f := fct ; 
y := b 
END ; 
lc := lc + 1 

END (*emitl*) 



PROCEDURE emit2(fct,a,b:integer) 

BEGIN 

IF lc = cmax THEN 
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fatal(6) ; 
WITH code[lc] DO 
BEGIN 



y 

END 



lc 
END 



(*emit2*) 



PROCEDURE printtables ; 
VAR 

i : integer ; 
o : order ; 

BEGIN 

writeln( ' Oidentif iers link obj typ ref nrm lev adr') 

writeln( ' printtables t = *,t) ; 

FOR i := btab[l].last TO t DO 
WITH tab[i] DO 

writeln(i, 1 name ,link:5,ord(obj) :5,ord(typ) :5,ref :5 
or d ( normal ) : 5 , le v : 5 , adr : 5 ) ; 
writeln( ' Oblocks last Ipar psze vsze') ; 

FOR i := 1 TO b DO 
WITH btab[i] DO 

writeln( i,last:5,lastpar:5,psize:5,vsize:5) ; 
wr i teln( ' Oarrays xtyp etyp eref low high elsz size*) 

FOR i := 1 TO a DO 
WITH atab[i] DO 

writeln(i,ord(inxtyp) :5,ord(eltyp) :5,elref:5,low:5, 
high : 5 , elsize : 5 , size : 5 ) ; 
wr i teln ( ' Ocode : ' ) ; 
FOR i := 0 TO lc - 1 DO 
BEGIN 

IF i MOD 5=0 THEN 
BEGIN 

writeln ; 
write(i : 5) 
END ; 
o : = code [ i ] ; 
wr i te ( o . f : 5 ) ; 
IF o.f < 31 THEN 
IF o.f < 4 THEN 

write(o.x:2,o.y:5) 
ELSE 

write ( o . y : 7 ) 

ELSE 

wr i te ( ' f ) ; 

write ( ' , ' ) 
END ; 
writeln 

END (*printtables*) 
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PROCEDURE block( f sy s : symset ; 

isfun : boolean ; 
level : integer ) ; 

LABEL 
quit ; 

TYPE 

conrec = RECORD 

CASE tp : types OF 

int s , char s , bools : (i:integer) ; 
reals : (r:real) 
END ; 

VAR 

dx : integer ; (*data allocation index*) 
prt : integer ; (*t-index of this procedure*) 
prb : integer ; (*b-index of this procedure*) 
x : integer ; 

PROCEDURE skip( fsys : symset ; 

n : integer ) ; 

LABEL 
quit ; 

BEGIN 

error(n) ; 
GOTO quit ; 

WHILE NOT (sy IN fsys) DO 
insymbol ; 

quit : 

END (*skip*) 



PROCEDURE test(sl ,s2:symset 
ntinteger) ; 



qui t : 

END 



LABEL 
quit ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
IF NOT (sy IN si) THEN 
ikip(sl + s2,n) ; 



(*test*) 



PROCEDURE testsemicolon ; 
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LABEL 
quit ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(H) ; 
GOTO quit ; 

IF sy IN [ comma , colon ] THEN 
insymbol 
END ; 

test ( [ ident ] + blockbegsy s , f sy s , 6 ) 

quit : 

END (*testsemicolon*) 



PROCEDURE enter(id :alfa ; 

k:object) ; 

LABEL 
quit ; 

VAR 

j , 1 : integer ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
IF t = tmax THEN 

fatal(l) 
ELSE 
BEGIN 

tab[0] .name := id ; 

j := btab[ display [ level ]]. last 

1 := j ; 

WHILE tab[j].name <> id DO 
BEGIN 

j := tab [j]. link ; 
IF recompile THEN 
GOTO quit ; 
END ; 
IF j <> 0 THEN 
BEGIN 

error ( 1 ) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

t := t + 1 ; 
WITH tab[t] DO 
BEGIN 

name := id ; 
link := 1 ; 
obj := k ; 
typ := notyp ; 
ref := 0 ; 
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lev := level ; 
adr := 0 
END ; 

btab [ display [ level ]]. last := t 
END 
END ; 

quit : 

END (*enter*) 



FUNCTION loc(id:alfa) : integer ; 

LABEL 
quit ; 

VAR 

i,j : integer ; (*locate id in table*) 

BEGIN 

IF recompile THEN 

GOTO quit ; 
i := level ; 

tab[0] .name := id ; (*sentinel*) 
REPEAT 

IF recompile THEN 

GOTO quit ; 
j := btab[ display [ i ]]. last ; 
WHILE tab[ j].name <> id DO 
BEGIN 

j := tab[ j] .link ; 
IF recompile THEN 
GOTO quit ; 
END ; 
i := i - 1 ; 
UNTIL (i < 0) OR (j <> 0) ; 
IF j = 0 THEN 
BEGIN 

error(O) ; 
GOTO quit ; 
END ; 
1 o c : = j ; 

quit : 

END (*loc*) 



PROCEDURE entervariable ; 

LABEL 
quit ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
IF sy = ident THEN 

BEGIN 

enter ( id , variable) ; 

insymbol 
END 
ELSE 

error(2) ; 
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quit : 

END (*entervariable*) 



PROCEDURE constant ( fsys : symset ; 

VAR ciconrec) ; 

LABEL 
quit ; 

VAR 

x,sign : integer ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
c . t p : = notyp ; 
c.i := 0 ; 

test (constbegsys , fsys , 50) ; 
IF sy IN constbegsys THEN 
BEGIN 

IF sy = charcon THEN 
BEGIN 

c . t p : = chars ; 
c.i : = inum ; 
insymbol 
END 
ELSE 
BEGIN 

sign : = 1 ; 

IF sy IN [plus, minus] THEN 
BEGIN 

IF sy = minus THEN 

sign : = — 1 ; 
insymbol 
END ; 
IF sy = ident THEN 
BEGIN 

x := loc(id) ; 

IF recompile THEN 

GOTO quit ; 
IF x <> 0 THEN 

IF tab[x].obj <> konstant THEN 
BEGIN 

error(25) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

c.tp := tab[x].typ ; 
IF c.tp = reals THEN 

c.r := sign * r const [ tab [ x ]. adr ] 

ELSE 

c.i := sign * tab[x].adr 
END ; 
insymbol 
END 

ELSE IF sy = intcon THEN 
BEGIN 

c.tp : = int s ; 
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c.i := sign * inum ; 
insymbol 
END 

ELSE IF sy = realcon THEN 
BEGIN 

c . t p : = reals ; 
c.r := sign * rnum ; 
insymbol 
END 
ELSE 

skip ( f sy s t 50) ; 
IF recompile THEN 
GOTO quit ; 
END ; 
test(f sy s , [ ] , 6) 
END ; 

quit : 

END (^constant*) 



PROCEDURE typ( f sys : symset ; 

VAR tp:types ; 

VAR rf , sz : integer ) ; 

LABEL 
quit ; 

VAR 

x : integer ; 

eltp : types ; 

elrf : integer ; 

elsz , of f set , tO , t 1 ; integer ; 

PROCEDURE arraytyp(VAR ar ef , ar sz : in teger ) ; 

LABEL 
quit ; 

VAR 

eltp : types ; 

low, high : conrec ; 

elrd,elsz : integer ; 

BEGIN 

IF recompile THEN 
GOTO quit ; 

constant ([ colon , rbrack , rparent , of sy ] + fsys.low) 
IF low.tp = reals THEN 
BEGIN 

error(27) ; 
GOTO quit ; 
low.tp := ints ; 
low.i := 0 
END ; 
IF sy = colon THEN 

insymbol 
ELSE 
BEGIN 

error ( 13) ; 
GOTO quit ; 
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END ; 

constant ([ rbrack , comma , r par ent , of sy ] + f sys.high) 
IF high.tp <> low.tp THEN 
BEGIN 

error(27) ; 
GOTO quit ; 
high.i := low.i 
END ; 

enterarray(low.tp, low .1, high.i) ; 
aref := a ; 
IF sy = comma THEN 
BEGIN 

insymbol ; 
eltp := arrays ; 
arraytyp(elrf,elsz) 
END 
ELSE 
BEGIN 

IF sy = rbrack THEN 

insymbol 
ELSE 
BEGIN 

error(12) ; 
GOTO quit ; 
IF sy = rparent THEN 
insymbol 
END ; 
IF sy = ofsy THEN 

insymbol 
ELSE 
BEGIN 

error(8) ; 
GOTO quit ; 
END ; 

typ(fsys, eltp, elrf, elsz) 
END ; 
WITH atabfaref] DO 
BEGIN 

arsz := (high — low + 1) * elsz ; 
size := arsz ; 
eltyp := eltp ; 
elref := elrf ; 
elsize := elsz 
END ; 

quit : 

END (*arraytyp*) 

BEGIN (*typ*) 
IF recompile THEN 

GOTO quit ; 
tp := notyp ; 
rf := 0 ; 
sz := 0 ; 

test ( typebegsy s , f sys , 10) ; 
IF sy IN typebegsys THEN 
BEGIN 

IF sy = ident THEN 
BEGIN 

x : = loc ( id ) ; 
IF x <> 0 THEN 
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WITH tab[x] DO 

IF obj <> typel THEN 
BEGIN 

error(29) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

tp := typ ; 
rf := ref ; 
sz := adr ; 
IF tp = notyp THEN 
BEGIN 

error(30) ; 
GOTO quit ; 
END ; 
END ; 
insymbol 
END 

ELSE IF sy = arraysy THEN 
BEGIN 

insymbol ; 

IF sy = Ibrack THEN 

insymbol 
ELSE 

BEGIN 

err or ( 1 1 ) ; 
GOTO quit ; 
IF sy = lparent THEN 
insymbol 
END ; 
tp := arrays ; 
arraytyp(rf,sz) 
END 
ELSE 
BEGIN 

insymbol ; 
enterblock ; 
tp := records ; 
rf := b ; 

IF level = lmax THEN 

fatal(5) ; 
level := level + 1 ; 
display [ level ] := b ; 
offset := 0 ; 
WHILE sy <> endsy DO 
BEGIN 

IF sy = ident THEN 
BEGIN 

tO := t ; 
en ter variable ; 
WHILE sy = comma DO 
BEGIN 

insymbol ; 
entervariable 
END ; 
IF sy = colon THEN 

insymbol 
ELSE 

BEGIN 



(♦records*) 



(*field section*) 



35 




error(5) ; 

GOTO quit ; 
END ; 
tl := t ; 
typ( f sy s 

+ [ semicolon , endsy , comma ,ident] ,eltp,elrf ,elsz) 

WHILE*tO < tl DO 
BEGIN 

tO := tO + 1 ; 
WITH tab[tO] DO 
BEGIN 

typ := eltp ; 
ref : = elr f ; 
normal := true ; 
adr := offset ; 
offset := offset + elsz 
END 

END 
END ; 

IF sy <> endsy THEN 
BEGIN 

IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(14) ; 
GOTO quit ; 
IF sy = comma THEN 
insymbol 
END ; 

test( [ident, endsy, semicolon] , f sy s , 6 ) 
END 
END ; 

btab [ r f ] . vsize := offset ; 
sz : = offset ; 
btab [ rf ] . psize := 0 ; 
insymbol ; 
level := level - 1 
END ; 
test ( f sys , [ ] , 6) 
END ; 

quit: 

END (*typ*) 



PROCEDURE parameter list ; (*formal parameter list*) 

LABEL 
quit ; 

VAR 

tp : types ; 

rf ,sz,x,tO : integer ; 

valpar : boolean ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
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tp := notyp ; 
rf := 0 ; 
sz := 0 ; 

test ([ ident , varsy ], fsys + [rparent],7) ; 
IF recompile THEN 

GOTO quit ; 
WHILE sy IN [ ident , varsy ] DO 
BEGIN 

IF sy <> varsy THEN 

valpar := true 
ELSE 
BEGIN 

insymbol ; 
valpar := false 
END ; 
tO := t ; 
enter variable ; 
WHILE sy = comma DO 
BEGIN 

insymbol ; 
enter variable ; 
END ; 
IF sy = colon THEN 
BEGIN 

insymbol ; 
IF sy <> ident THEN 
BEGIN 

error(2) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

x := loc(id) ; 
insymbol ; 
IF x <> 0 THEN 
WITH tab[x] DO 

IF obj <> typel THEN 
BEGIN 

error(29) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

tp := typ ; 
rf := ref ; 
IF valpar THEN 

sz := adr 
ELSE 

sz : = 1 
END ; 

END ; 

test ([ semicolon , r par ent ],[ comma , ident ] + fsys,14) 
END 
ELSE 
BEGIN 

error(5) ; 
GOTO quit ; 
END ; 
WHILE tO < t DO 
BEGIN 
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tO := tO + 1 ; 
WITH tab[tO] DO 
BEGIN 

typ := tp ; 
ref := rf ; 
normal : = valpar ; 
adr := dx ; 
lev := level ; 
dx := dx + sz 
END 
END ; 

IF sy <> rparent THEN 
BEGIN 

IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(U) ; 
GOTO quit ; 
IF sy = comma THEN 
insymbol 
END ; 

test ([ ident , varsy ],[ rparent ] + fsys,6) 
END 

END (*while*) 

IF sy = rparent THEN 
BEGIN 

insymbol ; 

test( [semicolon, colon] , f sys , 6) 
END 
ELSE 
BEGIN 

error(4) ; 

GOTO quit ; 
END ; 

quit : 

END ( *par ame t er li s t* ) 



PROCEDURE constantdeclaration ; 

LABEL 
quit ; 

VAR 

c : conrec ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 

test ([ ident ], blockbegsys , 2 ) ; 
WHILE sy = ident DO 
BEGIN 

enter ( id , konstant ) ; 

insymbol ; 

IF sy = egl THEN 

insymbol 
ELSE 
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BEGIN 

error ( 16) ; 

GOTO quit ; 

IF sy = becomes THEN 
insymbol 
END ; 

cons tant ([ semicolon , comma , ident ] + fsys,c) ; 
tab[t].typ := c.tp ; 
tab[t].ref := 0 ; 
IF c.tp = reals THEN 
BEGIN 

en t err eal ( c . r ) ; 
tab[t].adr := cl 
END 
ELSE 

tab[t].adr := c.i ; 
test semicolon 
END ; 

quit: END (*constantdeclaration*) 



PROCEDURE typedeclaration ; 

LABEL 
quit ; 

VAR 

tp : types ; 

rf ,sz,tl : integer ; 



IF recompile THEN 

GOTO quit ; 
insymbol ; 

tes t ( [ ident ] , blockbegsy s , 2 ) ; 
WHILE sy = ident DO 
BEGIN 

enter ( id , ty pel ) ; 
tl := t ; 
insymbol ; 
IF sy = egl THEN 

insymbol 
ELSE 
BEGIN 

error(16) ; 
GOTO quit ; 
IF sy = becomes THEN 
insymbol 
END ; 

typ ( [ semicolon , comma , ident ] + f sy s , t p , r f , sz ) 
WITH tab[tl] DO 
BEGIN 

typ := tp ; 
ref := rf ; 
adr := sz 
END ; 
testsemicolon 
END ; 

quit : 

END (*typedeclaration*) 
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PROCEDURE variabledeclaration ; 

LABEL 
quit ; 

VAR 

tO,tl,rf ,sz : integer ; 
tp : types ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
WHILE sy = ident DO 
BEGIN 

tO := t ; 
enter variable ; 
WHILE sy = comma DO 
BEGIN 

insymbol ; 
enter variable ; 
END ; 
IF sy = colon THEN 

insymbol 
ELSE 
BEGIN 

error(5) ; 
GOTO quit ; 
END ; 
tl := t ; 

typ ([ semicolon , comma , ident ] + f sy s , t p , r f , sz ) 
WHILE tO < tl DO 
BEGIN 

tO := tO + 1 ; 
WITH tab[tO] DO 
BEGIN 

typ := tp ; 
ref := rf ; 
lev := level ; 
adr := dx ; 
normal := true ; 
dx := dx + sz 
END 
END ; 
testsemicolon 
END ; 

quit : 

END (*variabledeclaration*) 



PROCEDURE procdeclaration ; 

LABEL 
quit ; 

VAR 

isfun : boolean ; 
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BEGIN 

IF recompile THEN 

GOTO quit ; 
isfun := sy = functionsy ; 
insymbol ; 
IF sy <> ident THEN 
BEGIN 

error(2) ; 
GOTO quit ; 
END ; 
IF isfun THEN 

enter(id,f unktion) 
ELSE 

enter ( id , prozedure ) ; 
tab [ t ]. normal := true ; 
insymbol ; 

block( [ semicolon ] + f sys , isfun , level + 1) ; 
IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(H) ; 
GOTO quit ; 
END ; 

emit(32 + ord(isfun)) (*exit*) 

quit : 

END (*proceduredeclaration*) 



PROCEDURE statement ( f sys : symset) ; 

LABEL 
quit ; 

VAR 

i : integer ; 
x : item ; 

PROCEDURE expression( f sys : symset ; 

VAR x:item) ; 

FORWARD ; 

PROCEDURE selector ( f sys : symset ; 

VAR v:item) ; 

LABEL 
quit ; 

VAR 

x : item ; 

a,j : integer ; 

BEGIN (*sy in [Iparent, lbrack, period]*) 
IF recompile THEN 

GOTO quit ; 
REPEAT 

IF recompile THEN 

GOTO quit ; 
IF sy = period THEN 
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BEGIN 

insymbol ; (*field selector*) 
IF sy <> ident THEN 
BEGIN 

error(2) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

IF v.typ <> records THEN 
BEGIN 

error(31) ; 
GOTO quit ; 
END 
ELSE 

BEGIN (*search field identifier*) 
j := btab[ v. ref ] . last ; 
tab [ 0 ]. name := id ; 
WHILE tab[j].name <> id DO 
BEGIN 

j := tab [j], link ; 
IF recompile THEN 
GOTO quit ; 
END ; 
IF j = 0 THEN 
BEGIN 

error(O) ; 
GOTO quit ; 
END ; 

v.typ := tab[j].typ ; 
v.ref := tab[ j] .ref ; 
a := tab[ j ] .adr ; 
IF a <> 0 THEN 
emitl(9,a) ; 
IF recompile THEN 
GOTO quit ; 
END ; 
insymbol 
END 

END 
ELSE 

BEGIN (*array selector*) 
IF sy <> lbrack THEN 
BEGIN 

error(ll) ; 
GOTO quit ; 
END ; 
REPEAT 

IF recompile THEN 

GOTO quit ; 
insymbol ; 

expr ession ( f sy s + [ comma , r brack ], x ) ; 
IF v.typ <> arrays THEN 
BEGIN 

error(28) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

a : = v.ref ; 
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IF atab[a] .inxtyp <> x.typ THEN 
BEGIN 

error(26) ; 

GOTO quit ; 
END 

ELSE IF atab[a] .elsize = 1 THEN 

emitl(20,a) 
ELSE 

emitl(21,a) ; 
v.typ := atab[a] . eltyp ; 
v.ref := atab [ a ] . elr ef ; 
IF recompile THEN 

GOTO quit ; 

END 

UNTIL sy <> comma ; 
IF sy = rbrack THEN 

insymbol 
ELSE 
BEGIN 

error(12) ; 
GOTO quit ; 
IF sy = rparent THEN 
insymbol 



END 
END ; 
IF recompile THEN 
GOTO quit ; 

UNTIL NOT (sy IN [ lbrack , lparent , per iod ] ) ; 
test(fsys,[],6) ; 

quit : 

END (*selector*) 



PROCEDURE call(f sys : symset ; 

irinteger) ; 

LABEL 
quit ; 

VAR 

x : item ; 

lastp,cp,k : integer ; 

BEGIN 

IF recompile THEN 
GOTO quit ; 



lastp := btab[ tab[i] .ref ] .lastpar ; 
cp := i ; 

IF sy = lparent THEN 

BEGIN (*actual parameter list*) 
REPEAT 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
IF cp >= lastp THEN 
BEGIN 



emitl (18, i) 



(♦mark stack*) 



error (39) 
GOTO quit 



END 
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ELSE 
BEGIN 

cp := cp + 1 ; 

IF tab[cp] .normal THEN 

BEGIN (*value parameter*) 

expr ession ( f sy s + [ comma , colon , r par ent ], x ) 
IF x.typ = tab[cp].typ THEN 
BEGIN 

IF x.ref <> tab[cp].ref THEN 
BEGIN 

error(36) ; 

GOTO quit ; 
END 

ELSE IF x.typ = arrays THEN 
emit 1 ( 22, atab[ x.ref] .size) 

ELSE IF x.typ = records THEN 
emit 1 ( 22, b tab [x.ref] .vsize) 

END 

ELSE IF (x.typ = ints) AND 

(tab[cp].typ = reals) THEN 
emitl(26,0) 
ELSE IF x.typ <> notyp THEN 
BEGIN 

error(36) ; 
GOTO quit ; 
END ; 

END 
ELSE 

BEGIN (*variable parameter*) 
IF sy <> ident THEN 
BEGIN 

error(2) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

k ;= loc(id) ; 
insymbol ; 
IF k <> 0 THEN 
BEGIN 

IF tab[k].obj <> variable THEN 
BEGIN 

error(37) ; 

GOTO quit ; 
END ; 

x.typ := tab[k].typ ; 
x.ref := tab[k].ref ; 
IF tab[k] .normal THEN 

emit2(0, tab[k] .lev, tab [k] .adr) 

ELSE 

emit2( 1 , tab[k] .lev,tab[k] .adr) ; 
IF sy IN [lbrack.lparent, period] THEN 

selector ( fsys + [ comma , colon , r par ent ], x ) ; 
IF (x.typ <> tab[cp].typ) OR (x.ref <> tab[cp], 

ref) THEN 

BEGIN 

error(36) ; 

GOTO quit ; 
END ; 

END 
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END 

END 
END ; 

tes t ( [ comma , rparent ] , f sy s , 6 ) ; 
IF recompile THEN 
GOTO quit ; 
UNTIL sy <> comma ; 
IF sy = rparent THEN 

insymbol 
ELSE 
BEGIN 

error(A) ; 
GOTO quit ; 
END ; 
END ; 
IF cp < lastp THEN 
BEGIN 

error(39) ; 
GOTO quit ; 
END ; (*too few actual parameters*) 
emitl(19, btab[tab[i] .ref ] .psize - 1) ; 
IF tab[i].lev < level THEN 
emit2(3,tab[i] .lev, level) ; 

quit : 

END (*call*) 



FUNCTION resulttype(a, b: types) : types ; 

LABEL 
quit ; 



BEGIN 

IF recompile THEN 

GOTO quit ; 
IF (a > reals) OR (b > reals) THEN 
BEGIN 

error(33) ; 
GOTO quit ; 
resulttype := notyp 
END 

ELSE IF (a = notyp) OR (b = notyp) THEN 

resulttype := notyp 
ELSE IF a = ints THEN 
IF b = ints THEN 

resulttype ints 
ELSE 
BEGIN 

resulttype := reals ; 
emitl(26,l) 
END 

ELSE 
BEGIN 

resulttype := reals ; 
IF b = ints THEN 
emitl(26,0) 
END ; 

quit : 

END (*resulttype*) 
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PROCEDURE expression ; 

LABEL 
quit ; 

VAR 

y : item ; 
op : symbol ; 

PROCEDURE simpleexpression( f sys : symset ; 

VAR x:item) ; 

LABEL 
quit ; 

VAR 

y : item ; 
op : symbol ; 

PROCEDURE term(f sys:symset ; 

VAR x:item) ; 

LABEL 
quit ; 

VAR 

y : item ; 
op : symbol ; 
ts : typset ; 

PROCEDURE factor(f sys : symset ; 

VAR xtitem) ; 

LABEL 
quit ; 

VAR 

i,f : integer ; 

PROCEDURE standfct(n: integer ) ; 

LABEL 
quit ; 

(* var ts : typset; *) 

BEGIN (^standard function no. n*) 
IF recompile THEN 

GOTO quit ; 
IF sy = lparent THEN 

insymbol 
ELSE 
BEGIN 

error(9) ; 
GOTO quit ; 
END ; 
IF n < 17 THEN 
BEGIN 

expr ession( f sy s + [rparent],x) ; 
CASE n OF 

46 



( *abs , sqr*) 
0,2 : BEGIN 

ts : = [ints, reals] ; 

tab[i].typ := x.typ ; 

IF x.typ = reals THEN 
n := n + 1 
END ; 
(*odd ( chr*) 
4,5 : ts := [ints] ; 
(*ord*) 

6 : ts := [ ints , bools , chars ] ; 

(*succ , pred*) 

7,8 : ts := [chars] ; 

(^round.trunc*) 

9,10,11,12,13,14,15,16 : 

(*sin , cos ,...#) 

BEGIN 

ts := [ints, reals] ; 
IF x.typ = ints THEN 
emitl(26,0) 
END ; 
END ; 

IF x.typ IN ts THEN 

emitl (8,n) 
ELSE IF x.typ <> notyp THEN 
BEGIN 

error(48) ; 
GOTO quit ; 
END 

END 
ELSE 

( *eof , eoln*) 
BEGIN 

IF sy <> ident THEN 
BEGIN 

error(2) ; 
GOTO quit ; 
END 

ELSE IF id <> 'input 
BEGIN 

error(O) ; 
GOTO quit ; 
END 
ELSE 

insymbol ; 
emitl(8,n) ; 
END ; 

x.typ := tab[i].typ ; 
IF sy = rparent THEN 

insymbol 
ELSE 
BEGIN 

error(4) ; 
GOTO quit ; 
END ; 



(*n in [17,18]*) 



quit : 



BEGIN 

IF recompile THEN 



(*standfct*) 
(*f actor*) 
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GOTO quit ; 
x.typ := notyp ; 
x.ref := 0 ; 

test ( f acbegsys , f sys , 58) ; 
IF recompile THEN 

GOTO quit ; 
WHILE sy IN facbegsys DO 
BEGIN 

IF recompile THEN 

GOTO quit ; 
IF sy = ident THEN 
BEGIN 

i := loc(id) ; 
insymbol ; 
WITH tab[i] DO 
CASE obj OF 

konstant : BEGIN 

x.typ := typ ; 

x.ref := 0 ; 

IF x.typ = reals THEN 

emitl(25,adr) 
ELSE 

emitl(24,adr) 
END ; 

variable : BEGIN 

x.typ := typ ; 
x.ref := ref ; 
IF sy IN [lbrack.lparent, period] THEN 
BEGIN 

IF normal THEN 

f := 0 
ELSE 

f := 1 ; 
emit2(f ,lev,adr) ; 
selector (f sys , x) ; 
IF x.typ IN stantyps THEN 

emit (34) 

END 
ELSE 
BEGIN 

IF x.typ IN stantyps THEN 

IF normal THEN 

f := 1 
ELSE 

f := 2 
ELSE IF normal THEN 

f := 0 
ELSE 

f := 1 ; 
emit2(f,lev,adr) 
END 
END ; 

typel f prozedure : BEGIN 

error(44) ; 
GOTO quit ; 
END ; 

funktion : BEGIN 

x.typ := typ ; 
IF lev <> 0 THEN 
call ( f sys , i ) 
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ELSE 

standfct(adr) 

END 

END (*case,with*) 

END 

ELSE IF sy IN [ charcon , in t con , realcon ] THEN 
BEGIN 

IF sy = realcon THEN 
BEGIN 

x.typ : = reals ; 
enter real ( mum) ; 
emitl(25,cl) 
END 
ELSE 
BEGIN 

IF sy = charcon THEN 

x.typ : «= chars 
ELSE 

x.typ := ints ; 
emit 1 ( 24 , inum) 
END ; 
x.ref := 0 ; 
insymbol 
END 

ELSE IF sy = lparent THEN 
BEGIN 

insymbol ; 

expression( f sys + [rparent],x) ; 
IF sy = rparent THEN 

insymbol 
ELSE 
BEGIN 

error(4) ; 
GOTO quit ; 
END 

END 

ELSE IF sy = notsy THEN 
BEGIN 

insymbol ; 

f actor(f sys,x) ; 

IF x.typ = bools THEN 

emit(35) 
ELSE IF x.typ <> notyp THEN 
BEGIN 

error(32) ; 
GOTO quit ; 
END 
END ; 

test(fsys,facbegsys f 6) 
END ; (*while*) 

quit : 

END (*factor*) 

BEGIN (*term*) 

IF recompile THEN 
GOTO quit ; 

factor(fsys + [ times , rdiv , idiv , imod , andsy ], x ) ; 
WHILE sy IN [ times , rdiv , idiv , imod , andsy ] DO 
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BEGIN 

IF recompile THEN 

GOTO quit ; 
op := sy ; 
insymbol ; 

factor(fsys + [ times , rdiv , idiv , imod , andsy ], y ) ; 
IF op = times THEN 
BEGIN 

x.typ := resulttype(x . typ , y . typ) ; 
CASE x.typ OF 

notyp : ; 

ints : emit(57) ; 

reals : emit(60) ; 
END 
END 

ELSE IF op = rdiv THEN 
BEGIN 
(* 

*) 

IF x.typ = ints THEN 
BEGIN 

emitl(26,l) ; 

x.typ := reals 
END ; 

IF y.typ = ints THEN 
BEGIN 

emitl(26,0) ; 

y.typ := reals 
END ; 

IF (x.typ = reals) AND (y.typ = reals) THEN 

emit(61 ) 
ELSE 

BEGIN 

IF ((x.typ <> notyp) AND (y.typ <> notyp)) THEN 
BEGIN 

error(33) ; 

GOTO quit ; 
END ; 

(* 

*) 

x.typ : = notyp 
END 

END 

ELSE IF op = andsy THEN 
BEGIN 

IF ((x.typ = bools) AND (y.typ = bools)) THEN 
emit(56) 
ELSE 
BEGIN 

IF ((x.typ <> notyp) AND (y.typ <> notyp)) THEN 
BEGIN 

error(32) ; 
GOTO quit ; 
END ; 
x.typ := notyp 
END 

END 
ELSE 

BEGIN (*op in [ indi v , imod ] * ) 

IF (x.typ = ints) AND (y.typ = ints) THEN 
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IF op = idiv THEN 

erait(58) 
ELSE 

emit(59) 

ELSE 
BEGIN 

IF (x.typ <> notyp) AND (y.typ <> notyp) THEN 
BEGIN 

error(34) ; 
GOTO quit ; 
END ; 
x.typ : — notyp 
END 

END 
END ; 

quit : 

END (*term*) 

BEGIN ( *simpleexpr ession* ) 
IF recompile THEN 

GOTO quit ; 
IF sy IN [plus, minus] THEN 
BEGIN 

op : = sy ; 
insymbol ; 

term(fsys + [ plus , minus ], x ) ; 
IF x.typ > reals THEN 
BEGIN 

error(33) ; 
GOTO quit ; 
END 

ELSE IF op = minus THEN 
emit(36) 

END 
ELSE 

term(fsys + [ plus t minus t or sy ], x ) ; 
WHILE sy IN [ plus , minus , orsy ] DO 
BEGIN 

IF recompile THEN 

GOTO quit ; 
op : = sy ; 
insymbol ; 

term(fsys + [ plus , minus , or sy ], y ) ; 
IF op = orsy THEN 
BEGIN 

IF (x.typ = bools) AND (y.typ = bools) THEN 

emit(51 ) 
ELSE 

BEGIN 

IF (x.typ <> notyp) AND (y.typ <> notyp) THEN 
BEGIN 

error(32) ; 
GOTO quit ; 
END ; 
x.typ := notyp 
END 

END 
ELSE 
BEGIN 

x.typ := resulttype(x.typ, y.typ) ; 
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CASE x.typ OF 
notyp : ; 

ints : IF op = plus THEN 
emit(52) 
ELSE 

emit(53) ; 
reals : IF op = plus THEN 
emit(54) 
ELSE 

emit(55) 

END 
END 
END ; 

quit : 

END ( *simpleexpression* ) 

BEGIN (^expression*) 
IF recompile THEN 
GOTO quit ; 

simpleexpr ession( f sy s + [ egl , neg , lss , leg , g tr , geg ] , x ) ; 
IF sy IN [egl, neg, lss, leg, gtr, geg] THEN 
BEGIN 

op := sy ; 

insymbol ; 

simpleexpression( f sys , y ) ; 
IF (x.typ IN [ notyp , ints , bools , chars ] ) 
AND (x.typ = y.typ) THEN 
CASE op OF 

egl : emit(45) ; 
neg : emit(46) ; 
lss : emit(47) ; 
leg : emit(48) ; 
gtr : emit(49) ; 
geg : emit(50) ; 
END 
ELSE 
BEGIN 

IF x.typ = ints THEN 
BEGIN 

x . typ : = reals ; 
emitl(26,l) 
END 

ELSE IF y.typ « ints THEN 
BEGIN 

y.typ := reals ; 

emitl ( 26 , 0) 
END ; 

IF (x.typ = reals) AND (y.typ = reals) THEN 
CASE op OF 

egl : emit(39) ; 

neg : emit(40) ; 

lss : emit(41) ; 

leg : emit(42) ; 

gtr : emit(43) ; 

geg : emit(44) ; 
END 
ELSE 
BEGIN 

error(35) ; 

GOTO quit ; 
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END 
END ; 
x.typ := bools 
END j 

quit : 

END (*(expression*) 



PROCEDURE assignment(lv,ad:integer) ; 

LABEL 
quit ; 



x,y : item ; 
f : integer ; 

(*tab[i].obj in [ va r ia bl e , prozedur e ] * ) 

BEGIN 

IF recompile THEN 

GOTO quit J 
x.typ := tab[i].typ ; 
x.ref := tab[i].ref ; 
IF tab[i]. normal THEN 

f := 0 
ELSE 

f := 1 ; 
emit2(f ,lv,ad) ; 

IF sy IN [lbrack.lparent, period] THEN 

selector([becomes,egl] + fays.x) ; 
IF sy = becomes THEN 

insymbol 
ELSE 
BEGIN 

error(51) ; 
GOTO quit ; 
IF sy = egl THEN 
insymbol 
END ; 

expression{f sys, y ) ; 
IF x.typ = y.typ THEN 

IF x.typ IN stantyps THEN 

emit(38) 
ELSE IF x.ref <> y.ref THEN 
BEGIN 

error(46) ; 
GOTO quit ; 
END 

ELSE IF x.typ - arrays THEN 

emit 1 (23, at a b[ x.ref ] .size) 
ELSE 

emit 1( 23, btab[ x.ref ].vsize) 
ELSE IF (x.typ = reals) AND (y.typ «= ints) THEN 
BEGIN 

emitl(26,0) ; 

emit(38) 
END 

ELSE IF (x.typ <> notyp) AND (y.typ <> notyp) THEN 
BEGIN 

error(A6) ; 
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GOTO quit ; 
END ; 

quit : 

END (*assignment*) 



PROCEDURE compoundstatement ; 

LABEL 
quit ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 

statement ([ semicolon , endsy ] + fsys) ; 
WHILE sy IN [semicolon] + statbegsys DO 
BEGIN 

IF recompile THEN 

GOTO quit ; 
IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(14) ; 
GOTO quit ; 
END ; 

sta tement ([ semicolon , endsy ] + fsys) 
END ; 
IF sy = endsy THEN 

insymbol 
ELSE 
BEGIN 

error(57) ; 
GOTO quit ; 
END ; 

quit : 

END (*compoundstatement*) 



PROCEDURE ifstatement ; 

LABEL 
quit ; 

VAR 

x : item ; 

lcl,lc2 : integer ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 

expr ession( f sys + [ thensy , dosy ] , x ) ; 
IF NOT (x.typ IN [ bools , not y p ] ) THEN 
BEGIN 

error(17) ; 
GOTO quit ; 
END ; 
lcl := lc ; 
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emit(ll) ; 

IF sy = thensy THEN 

insymbol 
ELSE 
BEGIN 

error(52) ; 
GOTO quit ; 
IF sy = dosy THEN 
insymbol 
END ; 

statement ( fsys + [elsesy] ) ; 
IF sy = elsesy THEN 
BEGIN 

insymbol ; 

lc2 := 1c ; 

emit(10) ; 

code[lcl].y : = 1c ; 

sta t ement ( f sy s ) ; 

code[lc2].y := lc 
END 
ELSE 

code[lcl].y := lc ; 

quit : 

END 



PROCEDURE casestatement ; 

LABEL 
quit ; 

VAR 

x : item ; 

i t j,k,lcl : integer ; 
casetab : ARRAY [L.csmax] OF PACKED RECORD 

val.lc : index 
END ; 

exittab : ARRAY [L.csmax] OF integer ; 

PROCEDURE caselabel ; 

LABEL 
quit ; 

VAR 

lab : conrec ; 
k : integer ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
constant ( fsys + [ comma , colon ], lab ) ; 
IF lab.tp <> x.typ THEN 
BEGIN 

error(47) ; 
GOTO quit ; 
END 

ELSE IF i = csmax THEN 

fatal(6) 
ELSE 



(* jmpc*) 



(*if statement*) 
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BEGIN 

i := i + 1 ; 
k := 0 ; 

casetab[ i ] . val := lab.i ; 
casetab [ i ] . lc := lc ; 
REPEAT 

IF recompile THEN 

GOTO quit ; 
k := k + 1 
UNTIL casetab[k] . val - lab.i ; 
IF k < i THEN 
BEGIN 

error(l) ; 
GOTO quit ; 
END (^multiple definition*) 
END ; 

quit : 

END (*caselabel*) 



PROCEDURE onecase ; 

LABEL 
quit ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
IF sy IN constbegsys THEN 
BEGIN 

caselabel ; 
WHILE sy = comma DO 
BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
caselabel 
END ; 
IF sy = colon THEN 

insymbol 
ELSE 
BEGIN 

error(5) ; 
GOTO quit ; 
END ; 

statement ([ semicolon , endsy ] + fsys) ; 
j := j + 1 ; 
exittabf j] := lc ; 
emit(10) 
END ; 

quit : 

END (*onecase*) 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
i := 0 ; 
j := 0 ; 

expression( f sys + [ of sy , comma , colon ], x ) ; 



56 



IF NOT (x.typ IN [ ints , bools , char s , noty p ] ) THEN 
BEGIN 

error(23) ; 
GOTO quit ; 
END ; 
lcl := lc ; 

emit(12) ; (*jmpx*) 
IF sy = ofsy THEN 

insymbol 
ELSE 
BEGIN 

error(8) ; 
GOTO quit ; 
END ; 
onecase ; 

WHILE sy = semicolon DO 
BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
onecase 
END ; 

code [ lcl ] . y : = lc ; 
FOR k := 1 TO i DO 
BEGIN 

emitl(13,casetab[k] .val) ; 
emitl(13,casetab[k].lc) ; 
IF recompile THEN 
GOTO quit ; 
END ; 
emitl(lO.O) ; 
FOR k := 1 TO j DO 

code[ exittabf k ] ] . y := lc ; 
IF sy = endsy THEN 

insymbol 
ELSE 
BEGIN 

error(57) ; 
GOTO quit ; 
END ; 

quit : 

END (*casestatement*) 



PROCEDURE repeatstatement ; 

LABEL 
quit ; 

VAR 

x : item ; 

lcl : integer ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
lcl := lc ; 
insymbol ; 

statement ([ semicolon , untilsy ] + fsys) ; 
WHILE sy IN [semicolon] + statbegsys DO 
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BEGIN 

IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(14) ; 
GOTO quit ; 
END ; 

statement ([ semicolon , untilsy ] + fsys) 
END : 

IF sy = untilsy THEN 
BEGIN 

insymbol ; 

expression( f sy s , x ) ; 

IF NOT (x.typ IN [ bools , noty p ] ) THEN 
BEGIN 

error(17) ; 
GOTO quit ; 
END ; 
emitl(ll,lcl) 
END 
ELSE 

error(53) ; 

quit : 

END ( *r epeatstatement*) 



PROCEDURE whilestatement ; 

LABEL 
quit ; 

VAR 

x : item ; 

lcl,lc2 : integer ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
lcl := lc ; 

expression ( fsys + [dosy] ,x) ; 
IF NOT (x.typ IN [ bools , not yp ] ) THEN 
BEGIN 

error(17) ; 
GOTO quit : 
END ; 
lc2 := lc ; 
emit(ll) ; 
IF sy = dosy THEN 

insymbol 
ELSE 
BEGIN 

error(54) ; 
GOTO quit ; 
END ; 
s ta tement ( f sy s ) ; 
emitl(10,lcl) ; 
code[lc2].y := lc ; 

quit z 
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END (*whilestatement*) 



PROCEDURE forstatement ; 

LABEL 
quit ; 

VAR 

cvt : types ; 
x : item ; 

i,f,lcl,lc2 : integer ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
IF sy o ident THEN 
BEGIN 

i := loc(id) ; 
insymbol ; 
IF i = 0 THEN 
cvt := ints 
ELSE IF tab[i].obj = variable THEN 
BEGIN 

cvt := tab[i].typ ; 
emit2(0,tab[i].lev,tab[i].adr) ; 

IF NOT (cvt IN [notyp, ints,bools, chars] ) THEN 
BEGIN 

error(18) ; 

GOTO quit ; 
END 

END 
ELSE 
BEGIN 

error(37) ; 

GOTO quit ; 

cvt := ints 
END 

END 
ELSE 

skip( [ becomes , tosy , downtosy , dosy ] + fsys,2) ; 
IF recompile THEN 

GOTO quit ; 
IF sy = becomes THEN 

BEGIN 

insymbol ; 

expression( [ tosy , downtosy , dosy ] + fsys.x) ; 
IF x.typ <> cvt THEN 
BEGIN 

error(19) ; 
GOTO quit ; 
END 

END 
ELSE 

skip( [ tosy , downtosy , dosy ] + fsys,51) ; 
IF recompile THEN 

GOTO quit j 
f := 14 ; 

IF sy IN [ tosy , downtosy ] THEN 
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BEGIN 

IF sy = downtosy THEN 

f := 16 ; 
insymbol } 

express±on( [ dosy ] + fsys,x) ; 
IF x.typ <> cvt THEN 
BEGIN 

error(19) ; 
GOTO quit ; 
END 

END 
ELSE 

skip([dosy] + fsys,55) ; 
IF recompile THEN 

GOTO quit ; 
lcl := lc ; 
emit(f) ; 
IF sy = dosy THEN 

insymbol 
ELSE 

BEGIN 

error(54) ; 
GOTO quit ; 

END ; 
lc2 := lc ; 
statement ( fsys) ; 
emitl(f + l,lc2) j 
code [ lcl ] . y : = lc ; 

quit : 

END (*forstatement*) 



PROCEDURE standproc(n:integer) ; 

LABEL 
quit ; 

VAR 

i f f : integer ; 
x,y : item ; 

BEGIN 

IF recompile THEN 

GOTO quit ; 
CASE n OF 

1,2 : BEGIN (*read*) 
IF (* not *) 

iflag THEN 
BEGIN 

error(20) ; 
GOTO quit ; 
iflag := true 
END ; 

IF sy = lparent THEN 
BEGIN 
REPEAT 

IF recompile THEN 

GOTO quit ; 
insymbol ; 
IF sy <> ident THEN 
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* # 



BEGIN 

error(2) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

i := loc(id) ; 

insymbol ; 

IF i <> 0 THEN 

IF tab[i].obj <> variable THEN 
BEGIN 

error(37) ; 
GOTO quit ; 
END 
ELSE 
BEGIN 

x.typ := tab[i].typ ; 
x.ref := tab[i].ref ; 
IF tab[i] .normal THEN 

f := 0 
ELSE 

f := 1 ; 

emit2(f , tab[i] ,lev,tab[i] .adr) ; 
IF sy IN [lbrack.lparent, period] THEN 

selector (fsys + [ comma , rparent ], x) ; 
IF x.typ IN [ ints , reals t chars f notyp ] THEN 
emit 1( 27, ord (x.typ)) 
ELSE 
BEGIN 

error(40) ; 
GOTO quit ; 
END 

END 

END ; 

test ([ comma , rparent ], fsys , 6) ; 
IF recompile THEN 
GOTO quit ; 
UNTIL sy <> comma ; 
IF sy = rparent THEN 

insymbol 
ELSE 
BEGIN 

error(4) ; 
GOTO quit ; 
END 
END ; 
IF n = 2 THEN 
emit(62) 
END ; 

3,4 : BEGIN (*write*) 
IF sy = lparent THEN 
BEGIN 
REPEAT 

IF recompile THEN 

GOTO quit ; 
insymbol ; 

IF sy = mstring THEN 
BEGIN 

emitl(24, sleng) ; 
emitl(28, inum) ; 
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insymbol 
END 
ELSE 
BEGIN 

expression( f sys + [ comma , colon , rparent ], x) 



IF NOT (x.typ IN stantyps) THEN 
BEGIN 

error(41) ; 
GOTO quit ; 
END ; 
IF sy = colon THEN 
BEGIN 



insymbol ; 

expression( f sys + [ comma , colon , r par ent ], y ) 
IF y.typ <> ints THEN 



error(43) ; 
GOTO quit ; 
END ; 
IF sy = colon THEN 
BEGIN 

IF x.typ <> reals THEN 
BEGIN 

error(42) ; 
GOTO quit ; 
END ; 
insymbol ; 
expr ession( f sys + [ comma , rparent ], y 
IF y.typ <> ints THEN 
BEGIN 

error(43) ; 
GOTO quit ; 
END ; 
emit(37) 
END 
ELSE 

emitl (30, ord(x. typ) ) 



END 
ELSE 

emitl (29, ord(x . typ) ) 
END ; 
IF recompile THEN 
GOTO quit ; 
UNTIL sy <> comma ; 
IF sy = rparent THEN 

insymbol 
ELSE 
BEGIN 

error(4) ; 
GOTO quit ; 
END 
END ; 
IF n = 4 THEN 
emit(63) 
END ; 



END 



( *case*) 



quit : 



END 



(*standproc*) 



62 



BEGIN (^statement*) 
IF recompile THEN 

GOTO quit ; 
IF sy IN statbegsys + [ident] THEN 
CASE sy OF 

ident : BEGIN 

i := loc(id) ; 

insymbol ; 

IF i <> 0 THEN 

CASE tab[i].obj OF 

konstant , typel : BEGIN 

error(45) ; 
GOTO quit ; 
END ; 

variable : BEGIN 

assignment (tab[i] .lev,tab[i] .adr) ; 
IF recompile THEN 
GOTO quit ; 
END ; 

prozedure : IF tab[i].lev <> 0 THEN 
call ( f sys ,i) 
ELSE 

standproc ( tab [ i ] . adr ) ; 
funktion : IF tab[i].ref = display [ level ] 
THEN assignment(tab[i].lev + 1,0) 
ELSE 
BEGIN 

error(45) ; 
GOTO quit ; 
END 

END 
END ; 

beginsy : compounds tatement ; 
ifsy : if is tatement j 
casesy : cases tatement ; 
whilesy : whiles tatement ; 
repeatsy : repeat statement ; 
forsy : forstatement ; 
END ; 
test(f sys, [ ] , 14) ; 

quit : 

END (*statement*) 

BEGIN (*block*) 
IF recompile THEN 

GOTO quit ; 
dx := 5 ; 
prt := t ; 

IF level > lmax THEN 
fatal(5) ; 

test( [1 parent, colon, semicolon ],fsys,7) ; 

enterblock ; 

display [ level ] := b ; 

prb := b ; 

tab[prt].typ := notyp ; 
tab[prt].ref := prb ; 
IF sy - lparent THEN 

parameterlist ; 
btab[ prb ] . lastpar := t ; 
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btab[ prb ] . psize := dx ; 
IF isfun THEN 

IF sy = colon THEN 
BEGIN 

insymbol ; (*function type*) 

IF sy = ident THEN 
BEGIN 

x := loc(id) ; 

insymbol ; 

IF x <> 0 THEN 

IF tab[x].obj <> typel THEN 
BEGIN 

error(29) ; 
GOTO quit ; 
END 

ELSE IF tab[x].typ IN stantyps THEN 

tab[prt].typ := tab[x].typ 
ELSE 
BEGIN 

error(15) ; 
GOTO quit ; 
END 

END 
ELSE 

skip ([ semicolon ] + fsys,2) ; 
IF recompile THEN 
GOTO quit ; 

END 
ELSE 
BEGIN 

error(5) ; 

GOTO quit ; 
END ; 

IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(14) ; 

GOTO quit ; 
END ; 
REPEAT 

IF recompile THEN 

GOTO quit ; 
IF sy = constsy THEN 

constantdeclaration ; 
IF sy = typesy THEN 

ty pedeclaration ; 
IF sy = varsy THEN 

variabledeclaration ; 
b tab [ pr b ] . vsize := dx ; 

WHILE sy IN [ proceduresy , f unctionsy ] DO 

procdeclaration ; 
test ( [ beginsy ] , blockbegsys + s ta t begsy s , 56 ) ; 
IF recompile THEN 
GOTO quit ; 
UNTIL sy IN statbegsys ; 
tab[prt].adr := lc ; 
insymbol ; 

statement ([ semicolon , endsy ] + fsys) ; 
WHILE sy IN [semicolon] + statbegsys DO 
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BEGIN 

IF recompile THEN 

GOTO quit ; 
IF sy = semicolon THEN 

insymbol 
ELSE 
BEGIN 

error(14) ; 
GOTO quit ; 
END ; 

statement ([ semicolon , endsy ] + fsys) 
END ; 
IF sy = endsy THEN 

insymbol 
ELSE 
BEGIN 

error(57) j 
GOTO quit ; 
END ; 

test(fsys + [period] ,[] ,6) ; 
quit : 

END (*block*) 



(* INTR.PAS *) 



PROCEDURE interpret ; 

(*global code, tab, btab*) 



VAR 
ir 
pc 
ps 



order ; ( *instr uc t ion buffer*) 
integer ; (*program counter*) 
(run,fin,caschk,divchk, inxchk f stkchk , 
linchk , lngchk , r edchk ) ; 
t : integer ; (*top stack index*) 
b : integer ; (*base index*) 

lncnt , ocnt , blkcnt , chrcnt : integer ; (*counters*) 
hl,h2,h3,h4 : integer ; 

fid : ARRAY [1..4] OF integer ; (*defalt field widths*) 

display ; ARRAY [L.lmax] OF integer ; 

s : ARRAY [ 1 . . s tacksize ] OF (* blockmark: *) 

RECORD 

CASE types OF (* s[b+0] 



ints 
reals 
bools 
chars 



( i : integer ) 
(rsreal) ; 
( b : boolean) 
( c : char) 



fct result *) 

(* s[b+l] - return adr *) 

(* s[b+2] = static link *) 

(* s[b+3] = dynamic link *) 

(* s[b+4] = table index *) 



BEGIN 
s[l].i 



(* interpret*) 
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4 



0 ; 

- 1 ; 

btabf 1 ] .last 



s[2].i 
s[3].i 

s[4].i 
b := 0 
display[l] s= 0 ; 
t := btab[2] .vsize - 1 ; 
pc := tab[s[4].i].adr ; 
ps : = run ; 
lncnt := 0 ; 
ocnt := 0 ; 
chrcnt : = 0 ; 

10 
22 
10 
1 ; 



fld[l] 
fld[2] 
fld[3] 
f ld[4] 
REPEAT 
ir : = 
pc : = 
ocnt 
CASE 
0 



; 



code[pc] 
pc + 1 ; 
: = ocnt + 
ir.f OF 

BEGIN 



t : = 



+ l ; 

stacksize THEN 
= stkchk 



t + 1 ; 

> stacksize THEN 
: = stkchk 



s [ display [ ir . x ] + ir.y] 



IF t 
ps 
ELSE 

s[t].i := display[ir .x] + 
END ; 
BEGIN 

t : 

IF 

ps 
ELSE 
s[t] 
END ; 
BEGIN 

t := t + 1 ; 

IF t > stacksize THEN 

ps :« stkchk 
ELSE 

s[t] := s[s[display[ir.x] 
END ; 
BEGIN 

hi := ir.y ; 
h2 := ir.x ; 
h3 := b ; 
REPEAT 

display[hl] 

hi hi - 1 

h3 : = s[h3 + 
UNTIL hi = h2 



(*load address*) 

ir.y 

(♦load value*) 



(*load indirect*) 
ir .y ] .i] 

(♦update display*) 



:= h.3 



2].i 



END ; 
CASE 








ir.y OF 






0 : 


s[t].i 


:= abs(s[t] 


• i) ; 


1 : 


s[t] .r 


:= abs(s[t] 


.r) ; 


2 : 


s[t].i 


:= sqr(s[t] 


• i) ; 


3 : 


s[t].r 


:» sqr(s[t] 


• r) ; 


4 : 


s[t].b 


:= odd(s[t] 


• i) ; 


5 : 


BEGIN 


(* s[t].c 


:= chr(s[t].i) *) 



IF (s[t].i < 0) OR (s[t].i > 63) THEN 
ps := inxchk 
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6 : (* s[t].i := ord(s[t].c) *) 

7 : s[t].c := succ(s[t].c) ; 

8 : s[t].c := pred(s[t].c) ; 

9 : s[t].i := round(s[ t ] . r) ; 

10 : s[t].i := tr unc ( s [ t ] . r ) ; 

11 : s[t].r := s±n(s[t].r) ; 

12 : s[t].r : = cos(s[t].r) ; 

13 : s[t].r := exp(s[tj.r) ; 

14 : s[t].r := ln(s[t].r) ; 

15 : s[t].r := sqrt(s[t].r) ; 

16 : s[t].r := arctan( s [ t ] . r ) ; 

17 : BEGIN 

t :» t + 1 ; 

IF t > stacksize THEN 

ps := stkchk 
ELSE 

s[t].b := eoln(input) 
END ; 

18 : BEGIN 

t := t + 1 ; 

IF t > stacksize THEN 

ps := stkchk 
ELSE 

s[t].b := eoln(input) 
END ; 

END ; 

s[t].i := s[t].i + ir.y ; (*offset*) 
pc := ir.y ; (*jump*) 
BEGIN (^conditional jump*) 
IF NOT s[t] .b THEN 

pc : = ir . y ; 
t := t - 1 
END ; 

BEGIN (*switch*) 
hi := s[t] .i ; 
t := t - 1 ; 
h2 := ir.y ; 
h3 := 0 ; 
REPEAT 

IF code[h2].f <> 13 THEN 
BEGIN 

h3 := 1 ; 
ps := caschk 
END 

ELSE IF code[h2].y = hi THEN 
BEGIN 

h3 := 1 ; 

pc := code[h2 + l].y 
END 
ELSE 

h2 := h2 + 2 
UNTIL h3 <> 0 
END ; 

BEGIN (*forlup*) 
hi := s[ t - 1 ] .i ; 
IF hi <= s[t].i THEN 
s[s[ t - 2] .i] .i := hi 

ELSE 
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2].i 



BEGIN 

t := t - 
pc : = ir 
END 
END ; 
BEGIN 

h2 := s[t - 
hi := s[h2] .i + 1 
IF hi <= s[t].i THEN 
BEGIN 

s[h2] .i ;= hi ; 
pc := ir.y 
END 
ELSE 

t := t - 3 ; 
END ; 
BEGIN 

hi := s[t - 1 ] .1 ; 



(*for2up*) 



(*f or ldown*) 



ir.y 

t - 3 



IF hi >= s[t].i THEN 
s[s[t - 2].i].i := 
ELSE 
BEGIN 
pc 
t ; 
END 
END ; 
BEGIN 

h2 ;= s[t - 2] .i ; 
hi := s[h2] .i - 1 ; 
IF hi >= s[t].i THEN 
BEGIN 

s[h2].i := hi ; 
pc := ir.y 
END 
ELSE 

t := t - 3 ; 
END ; 
BEGIN 

hi := btab[tab[ir.y].ref ] 
IF t + hi > stacksize THEN 

ps : = stkchk 
ELSE 
BEGIN 

t :» t + 5 ; 
s[ t - 1 ] .i hi - 1 ; 
s[ t] .i := ir.y 
END 
END ; 
BEGIN 



(*for2down*) 



(♦mark stack*) 
vsize ; 



(♦call*) 



hi := t - ir.y ; (*hl points to base*) 
h2 := s[hl + 4].i ;(*h2 points to tab*) 
h3 := tab[h2].lev ; 
display[h3 + 1] := hi ; 
h4 := s[hl + 3] .i + hi ; 
s[hl + 1 ] .i := pc ; 
s[hl + 2].i != display[h3] ; 
s[hl + 3].i := b ; 
FOR h3 := t + 1 TO h4 DO 

s[h3] .i := 0 ; 
b := hi ; 
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4 



20 



t := h4 
pc : = ti 

END ; 

BEGIN 



tab[h2] .adr 



(*indexl*) 



hi := ir.y ; (*hl points to atab*) 
h2 := atab[hl].low ; 
h3 := s[t] .i ; 
IF h3 < h2 THEN 

ps := inxchk 
ELSE IF h3 > atab[hl ] .high THEN 

ps := inxchk 
ELSE 

BEGIN 

t := t - 1 ; 

s[t].i := s[t].i + (h3 - h2) 



hi := ir.y ; (*hl points to atab*) 
h2 := atab[hl].low ; 
h3 := s[t].i ; 
IF h3 < h2 THEN 

ps := inxchk 
ELSE IF h3 > atabfhl ] .high THEN 

ps := inxchk 
ELSE 

BEGIN 

t := t - 1 ; 

s[t].i := s[t].i + (h3 - h2) * atabfhl] .elsize 

END 
END ; 

BEGIN (*load block*) 

hi := s[ t] ,i ; 
t := t - 1 ; 
h2 : = ir.y + t ; 
IF h2 > stacksize THEN 

ps := stkchk 
ELSE 

WHILE t < h2 DO 
BEGIN 



END 

END ; 

23 : BEGIN (*copy bloc 

hi := s[t - l].i ; 
h2 := s[t] ,i ; 
h3 :« hi + ir.y ; 
WHILE hi < h3 DO 
BEGIN 

s[hl] := s[h2] ; 
hi :- hi + 1 ; 
h2 := h2 + 1 
END ; 
t := t - 2 
END ; 

24 : BEGIN (*literal*) 

t := t + 1 ; 

IF t > stacksize THEN 



END 



21 



END ; 
BEGIN 



(♦index* ) 



t := t + 1 ; 
s[t] := s[hl] 
hi := hi + 1 
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.i := ir. 



stacksize THEN 
= stkchk 



(*load real*) 



rconst [ ir.y] 



ir.y; s[hl].i 



ps := stkchk 
ELSE 
s[t] 
END ; 

25 : BEGIN 

t := t 
IF t > 
ps : 
ELSE 
s[t] 
END ; 

26 : BEGIN 

(*float) hi := t - 

end ; 
27: begin (*read*) 

IF eoln(input) THEN 

ps := redchk 
ELSE 

CASE ir.y OF 

1 : read(s[s[t] 

2 : read(s[s[t].i].r) 
4 : read(s[s[t].i].c) 

END ; 
t := t - 1 
END j 

28 : BEGIN 

hi := s[t].i ; 
h2 := ir.y ; 
t := t - 1 ; 
chrcnt : = chrcnt + hi ; 
IF chrcnt > lineleng THEN 

ps := lngchk ; 
REPEAT 

write(stab[h2] ) ; 

hi := hi - 1 ; 

h2 := h2 + 1 
UNTIL hi = 0 
END ; 

29 : BEGIN (*writel*) 

chrcnt := chrcnt + fldfir.y] ; 
IF chrcnt > lineleng THEN 
ps := lngchk 



(*write string*) 



ELSE 
CASE 

1 : 

2 : 

3 : 

4 : 
END j 
:= t 



ir.y OF 
write(s[t] .i:fld[l]) 
write(s[t] .r :fld[2] ) 
write(s[t] .b:fld[3] ) 
write(s[t].c) ; 



t 

END ; 
BEGIN 

chrcnt := chrcnt + s[t].i 
IF chrcnt > lineleng THEN 

ps := lngchk 
ELSE 

CASE ir.y OF 

1 : write(s[t - l].i:s[t], 

2 : write(s[t - 1 ] .r:s[t] . 

3 : write(s[t - l].b:s[t]. 



(*writel*) 
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4 : write(s[t - 1 ] . c : s [ t ] . i ) ; 
END ; 
t :« t - 2 
END ; 

31 : ps := fin ; 

32 : BEGIN (*exit procedure*) 

t :« b - 1 ; 
pc := s[b + 1 ] .1 ; 
b := s[b + 3] .i 
END ; 

33 : BEGIN (*exit function*) 

t := b ; 

pc := s[ t + 1 ] .i ; 
b := s[b + 3] .i 

END ; 

34 : s[t ] := s[s[t] .i] ; 

35 : s[t] .b :~ NOT s[t] .b ; 

36 : s[ t ] .i := - s[ t] .i ; 

37 : BEGIN 

chrcnt := chrcnt + s[t - l].i ; 
IF chrcnt > lineleng THEN 

ps : - lngchk 
ELSE 

write(s[t - 2].r:s[t - l].i:s[t].i) 

t := t - 3 
END ; 

38 : BEGIN (*store*) 

s[s[t - l].i] := s[t] ; 
t := t - 2 
END ; 

39 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].r = s[t + l].r 

END ; 

40 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].r <> s[t + l].r 
END ; 

41 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].r < s[t + l].r 
END ; 

42 : BEGIN 

t :« t - 1 ; 

s[t].b :» s[t].r <= s[t + l].r 
END ; 

43 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].r > s[t + l].r 
END ; 

44 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].r >= s[t + l].r 
END ; 

45 : BEGIN 

t := t - 1 j 

s[t].b := s[t].i = s[t + l].i 
END ; 

46 : BEGIN 

t := t - 1 ; 
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s[t].b := s[t].i <> s[t + l].i 

END ; 

47 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].i < s[t + l].i 
END ; 

48 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].i <= s[t + 
END ; 

49 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].i > s[t + l].i 
END ; 

50 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].i >= s[t + l].i 
END ; 

51 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].b OR s[t + l].b 

END ; 

52 : BEGIN 

t := t - 1 ; 

s[t].i := s[t].i + s[t + l].i 
END ; 

53 : BEGIN 

t := t - 1 ; 

s[t].i := s[t].i - s[t + l].i 

END ; 

54 : BEGIN 

t := t - 1 ; 

s[t].r := s[t].r + s[t + l].r ; 
END ; 

55 : BEGIN 

t := t - 1 ; 

s[t].r := s[t].r - s[t + l].r ; 
END ; 

56 : BEGIN 

t := t - 1 ; 

s[t].b := s[t].b AND s[t + lj.b 
END ; 

57 : BEGIN 

t := t - 1 ; 

s[t].i := s[t].i * s[t + l].i 
END ; 

58 : BEGIN 

t := t - 1 ; 

IF s[t + 1].± = 0 THEN 

ps : = divchk 
ELSE 

s[t].i := s[t].i DIV s[t + l].i 
END ; 

59 : BEGIN 

t := t - 1 ; 

IF s[ t + 1 ] .i = 0 THEN 

ps := divchk 
ELSE 

s[t].i i= s[t].i MOD s[t + l].i 

END ; 
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60 : BEGIN 

t := t - 1 ; 
s[t].r := s[t].r * s[t + l].r ; 
END ; 

61 : BEGIN 

t := t - 1 ; 

s[t].r := s[t].r / s[t + l].r ; 
END ; 

62 : IF eoln(input) THEN 

ps := redchk 
ELSE 

readln ; 

63 : BEGIN 

writeln ; 

lncnt := lncnt + 1 j 
chrcnt := 0 ; 
IF lncnt > linelimit THEN 
ps := linchk 

END 

END (*case*) 

UNTIL ps <> run ; 
IF ps <> fin THEN 
BEGIN 

writeln ; 

write('Ohalt at' ,pc:5, 'because of) ; 
CASE ps OF 

caschk : writeln (' undefined case') ; 

divchk : writeln (* divison by 0') ; 

inxchk : writeln ( 1 invalid index 1 ) ; 

stkchk : writeln( ' storage overflow*) ; 

linchk : writeln( 'too much output 1 ) ; 

lngchk : wr i teln ( ' line too long' ) ; 

redchk : wri teln (* reading past end of file') ; 
END ; 
hi := b ; 

blkcnt :=> 10 ; (*post mortem dump*) 
REPEAT 

writeln ; 

blkcnt := blkcnt - 1 ; 
IF blkcnt = 0 THEN 

hi := 0 ; 
h2 := s[hl + 4].i ; 
IF hi <> 0 THEN 

writelnC ', tab [ h2 ]. name ,' called at',s[hl + l].i:5) 
h2 := btab[ tab[h2] .ref ] .last ; 
WHILE h2 <> 0 DO 
WITH tab[h2] DO 
BEGIN 

IF obj = variable THEN 
IF typ IN stantyps THEN 
BEGIN 

write(' ',name,' = ') ; 

IF normal THEN 

h3 := hi + adr 
ELSE 

h3 := s[hl + adr].i ; 
CASE typ OF 

ints : writeln(s[h3] .i) ; 
reals : wr iteln( s [ h3 ] . r ) ; 
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bools : writeln(s[h3] .b) ; 
chars : writeln(s[h3] ,c) ; 
END 
END ; 
h2 := link 
END ; 
hi := s[hl + 3].i 
UNTIL hi < 0 ; 
END ; 
writeln ; 

writeln(ocnt, 'steps*) 
END (interpret*) 



( ******* 
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